From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- pkg/README | 18 + pkg/bench/README | 2 + pkg/bench/bench.cl | 23 + pkg/bench/bench.hlp | 1723 +++ pkg/bench/bench.ms | 788 ++ pkg/bench/bench_tab.ms | 98 + pkg/bench/fortask.cl | 15 + pkg/bench/mkpkg | 5 + pkg/bench/plots.cl | 20 + pkg/bench/subproc.cl | 18 + pkg/bench/x_bench.x | 229 + pkg/bench/xctest/README | 2 + pkg/bench/xctest/columns.x | 74 + pkg/bench/xctest/lintran.x | 370 + pkg/bench/xctest/mkpkg | 25 + pkg/bench/xctest/table.x | 111 + pkg/bench/xctest/tokens.x | 140 + pkg/bench/xctest/unique.x | 46 + pkg/bench/xctest/words.x | 44 + pkg/bench/xctest/x_lists.x | 10 + pkg/cl/README | 17 + pkg/cl/binop.c | 664 + pkg/cl/bkg.c | 647 + pkg/cl/builtin.c | 2397 ++++ pkg/cl/cl.par | 56 + pkg/cl/cl.x | 30 + pkg/cl/clmodes.h | 67 + pkg/cl/clprintf.c | 214 + pkg/cl/clsystem.c | 68 + pkg/cl/compile.c | 247 + pkg/cl/config.h | 76 + pkg/cl/construct.h | 44 + pkg/cl/debug.c | 457 + pkg/cl/decl.c | 878 ++ pkg/cl/doc/pset.sys | 222 + pkg/cl/edcap.c | 392 + pkg/cl/eparam.c | 2182 ++++ pkg/cl/eparam.h | 108 + pkg/cl/errs.c | 255 + pkg/cl/errs.h | 52 + pkg/cl/exec.c | 1281 ++ pkg/cl/globals.c | 119 + pkg/cl/gquery.c | 207 + pkg/cl/gram.c | 1364 ++ pkg/cl/grammar.h | 61 + pkg/cl/grammar.l | 198 + pkg/cl/grammar.y | 2020 +++ pkg/cl/history.c | 1159 ++ pkg/cl/lex.com | 12 + pkg/cl/lex.sed | 4 + pkg/cl/lexicon.c | 655 + pkg/cl/lexyy.c | 897 ++ pkg/cl/lists.c | 125 + pkg/cl/login.cl | 97 + pkg/cl/logout.cl | 5 + pkg/cl/main.c | 716 + pkg/cl/mem.h | 109 + pkg/cl/mkpkg | 180 + pkg/cl/modes.c | 1279 ++ pkg/cl/opcodes.c | 1447 +++ pkg/cl/opcodes.h | 95 + pkg/cl/operand.c | 429 + pkg/cl/operand.h | 167 + pkg/cl/param.c | 1423 ++ pkg/cl/param.h | 220 + pkg/cl/pfiles.c | 1991 +++ pkg/cl/prcache.c | 724 ++ pkg/cl/proto.h | 447 + pkg/cl/scan.c | 350 + pkg/cl/stack.c | 211 + pkg/cl/tags | 481 + pkg/cl/task.c | 580 + pkg/cl/task.h | 211 + pkg/cl/unop.c | 369 + pkg/cl/y.output | 6737 ++++++++++ pkg/cl/ytab.c | 4512 +++++++ pkg/cl/ytab.h | 165 + pkg/dataio/Revisions | 887 ++ pkg/dataio/bintext/mkpkg | 11 + pkg/dataio/bintext/t_bintxt.x | 65 + pkg/dataio/bintext/t_txtbin.x | 65 + pkg/dataio/bintxt.par | 4 + pkg/dataio/cardimage/conversion.x | 221 + pkg/dataio/cardimage/mkpkg | 13 + pkg/dataio/cardimage/rcardimage.com | 10 + pkg/dataio/cardimage/structure.hlp | 139 + pkg/dataio/cardimage/t_rcardimage.x | 271 + pkg/dataio/cardimage/t_wcardimage.x | 256 + pkg/dataio/cardimage/tabs.x | 67 + pkg/dataio/cardimage/wcardimage.com | 8 + pkg/dataio/dataio.cl | 19 + pkg/dataio/dataio.hd | 27 + pkg/dataio/dataio.men | 13 + pkg/dataio/dataio.par | 4 + pkg/dataio/doc/Mtio_notes | 12 + pkg/dataio/doc/Rfits_notes | 85 + pkg/dataio/doc/bintxt.hlp | 28 + pkg/dataio/doc/export.hlp | 1066 ++ pkg/dataio/doc/import.hlp | 631 + pkg/dataio/doc/mtexamine.hlp | 84 + pkg/dataio/doc/rcardimage.hlp | 120 + pkg/dataio/doc/reblock.hlp | 177 + pkg/dataio/doc/rfits.hlp | 228 + pkg/dataio/doc/rtextimage.hlp | 84 + pkg/dataio/doc/t2d.hlp | 70 + pkg/dataio/doc/txtbin.hlp | 28 + pkg/dataio/doc/wcardimage.hlp | 74 + pkg/dataio/doc/wfits.hlp | 237 + pkg/dataio/doc/wtextimage.hlp | 100 + pkg/dataio/export.par | 13 + pkg/dataio/export/Notes | 37 + pkg/dataio/export/bltins/exeps.x | 537 + pkg/dataio/export/bltins/exgif.x | 557 + pkg/dataio/export/bltins/exiraf.x | 110 + pkg/dataio/export/bltins/exmiff.x | 81 + pkg/dataio/export/bltins/expgm.x | 47 + pkg/dataio/export/bltins/exppm.x | 49 + pkg/dataio/export/bltins/exras.x | 117 + pkg/dataio/export/bltins/exrgb.x | 74 + pkg/dataio/export/bltins/exvicar.x | 111 + pkg/dataio/export/bltins/exxwd.x | 253 + pkg/dataio/export/bltins/mkpkg | 20 + pkg/dataio/export/cmaps.inc | 534 + pkg/dataio/export/exbltins.h | 28 + pkg/dataio/export/exbltins.x | 243 + pkg/dataio/export/excmap.x | 258 + pkg/dataio/export/exfcn.h | 25 + pkg/dataio/export/exhdr.x | 207 + pkg/dataio/export/exobands.gx | 390 + pkg/dataio/export/export.h | 155 + pkg/dataio/export/expreproc.x | 352 + pkg/dataio/export/exraster.gx | 621 + pkg/dataio/export/exrgb8.x | 994 ++ pkg/dataio/export/exzscale.x | 755 ++ pkg/dataio/export/generic/exobands.x | 489 + pkg/dataio/export/generic/exraster.x | 709 + pkg/dataio/export/generic/mkpkg | 12 + pkg/dataio/export/mkpkg | 36 + pkg/dataio/export/t_export.x | 1160 ++ pkg/dataio/export/zzedbg.x | 157 + pkg/dataio/fits/fits_cards.x | 292 + pkg/dataio/fits/fits_files.x | 374 + pkg/dataio/fits/fits_params.x | 248 + pkg/dataio/fits/fits_read.x | 469 + pkg/dataio/fits/fits_rheader.x | 888 ++ pkg/dataio/fits/fits_rimage.x | 557 + pkg/dataio/fits/fits_rpixels.x | 154 + pkg/dataio/fits/fits_wheader.x | 469 + pkg/dataio/fits/fits_wimage.x | 497 + pkg/dataio/fits/fits_wpixels.x | 162 + pkg/dataio/fits/fits_write.x | 246 + pkg/dataio/fits/mkpkg | 24 + pkg/dataio/fits/rfits.com | 18 + pkg/dataio/fits/rfits.h | 96 + pkg/dataio/fits/t_rfits.x | 216 + pkg/dataio/fits/t_wfits.x | 253 + pkg/dataio/fits/wfits.com | 17 + pkg/dataio/fits/wfits.h | 128 + pkg/dataio/import.par | 30 + pkg/dataio/import/README | 2 + pkg/dataio/import/bltins/README | 13 + pkg/dataio/import/bltins/ipcmap.x | 76 + pkg/dataio/import/bltins/ipgif.x | 883 ++ pkg/dataio/import/bltins/ipras.x | 504 + pkg/dataio/import/bltins/ipxwd.x | 188 + pkg/dataio/import/bltins/mkpkg | 13 + pkg/dataio/import/fmtdb.x | 610 + pkg/dataio/import/generic/ipdb.x | 813 ++ pkg/dataio/import/generic/ipfio.x | 569 + pkg/dataio/import/generic/ipobands.x | 375 + pkg/dataio/import/generic/ipproc.x | 921 ++ pkg/dataio/import/generic/mkpkg | 15 + pkg/dataio/import/images.dat | 433 + pkg/dataio/import/import.h | 132 + pkg/dataio/import/ipbuiltin.x | 91 + pkg/dataio/import/ipdb.gx | 766 ++ pkg/dataio/import/ipfcn.h | 57 + pkg/dataio/import/ipfio.gx | 443 + pkg/dataio/import/ipinfo.x | 256 + pkg/dataio/import/iplistpix.x | 137 + pkg/dataio/import/ipmkhdr.x | 63 + pkg/dataio/import/ipobands.gx | 306 + pkg/dataio/import/ipproc.gx | 804 ++ pkg/dataio/import/mkpkg | 37 + pkg/dataio/import/t_import.x | 768 ++ pkg/dataio/import/zzidbg.x | 145 + pkg/dataio/imtext/imtext.h | 21 + pkg/dataio/imtext/mkpkg | 19 + pkg/dataio/imtext/putcplx.x | 88 + pkg/dataio/imtext/putint.x | 160 + pkg/dataio/imtext/putreal.x | 88 + pkg/dataio/imtext/rt_cvtpix.x | 115 + pkg/dataio/imtext/rt_rheader.x | 170 + pkg/dataio/imtext/rt_rwpix.x | 271 + pkg/dataio/imtext/t_rtextimage.x | 109 + pkg/dataio/imtext/t_wtextimage.x | 261 + pkg/dataio/imtext/wtextimage.semi | 91 + pkg/dataio/imtext/wti_wheader.x | 152 + pkg/dataio/lib/addcards.x | 140 + pkg/dataio/lib/getdatatype.x | 57 + pkg/dataio/lib/mkpkg | 12 + pkg/dataio/lib/ranges.x | 234 + pkg/dataio/mkpkg | 33 + pkg/dataio/mtexamine.par | 8 + pkg/dataio/mtexamine/mkpkg | 10 + pkg/dataio/mtexamine/mtexamine.com | 6 + pkg/dataio/mtexamine/t_mtexamine.x | 376 + pkg/dataio/rcardimage.par | 14 + pkg/dataio/reblock.par | 16 + pkg/dataio/reblock/mkpkg | 12 + pkg/dataio/reblock/reblock.com | 21 + pkg/dataio/reblock/reblock.h | 7 + pkg/dataio/reblock/reblock.hlp | 154 + pkg/dataio/reblock/reblock_file.x | 416 + pkg/dataio/reblock/structure.hlp | 50 + pkg/dataio/reblock/t_reblock.x | 214 + pkg/dataio/rfits.par | 12 + pkg/dataio/rtextimage.par | 9 + pkg/dataio/t2d.par | 5 + pkg/dataio/t2d/mkpkg | 10 + pkg/dataio/t2d/t_t2d.x | 280 + pkg/dataio/txtbin.par | 4 + pkg/dataio/wcardimage.par | 11 + pkg/dataio/wfits.par | 18 + pkg/dataio/wtextimage.par | 8 + pkg/dataio/x_dataio.x | 17 + pkg/dbms/dbms.cl | 4 + pkg/dbms/dbms.par | 3 + pkg/ecl/Notes.ecl | 1098 ++ pkg/ecl/README | 17 + pkg/ecl/Revisions | 31 + pkg/ecl/binop.c | 826 ++ pkg/ecl/bkg.c | 649 + pkg/ecl/builtin.c | 2583 ++++ pkg/ecl/cl.csh | 157 + pkg/ecl/cl.csh.SSOL | 94 + pkg/ecl/cl.par | 56 + pkg/ecl/clmodes.h | 78 + pkg/ecl/clprintf.c | 205 + pkg/ecl/clsystem.c | 67 + pkg/ecl/compile.c | 253 + pkg/ecl/config.h | 76 + pkg/ecl/construct.h | 44 + pkg/ecl/debug.c | 486 + pkg/ecl/decl.c | 850 ++ pkg/ecl/doc/ecl.hlp | 1099 ++ pkg/ecl/doc/pset.sys | 222 + pkg/ecl/ecl.x | 30 + pkg/ecl/ecl_install.csh | 414 + pkg/ecl/edcap.c | 390 + pkg/ecl/eparam.c | 2156 ++++ pkg/ecl/eparam.h | 108 + pkg/ecl/errs.c | 401 + pkg/ecl/errs.h | 72 + pkg/ecl/errtest/errif.cl | 24 + pkg/ecl/errtest/errtest.cl | 25 + pkg/ecl/errtest/errtest.hd | 9 + pkg/ecl/errtest/errtest.men | 14 + pkg/ecl/errtest/errtest.par | 3 + pkg/ecl/errtest/errtype.cl | 74 + pkg/ecl/errtest/mkpkg | 9 + pkg/ecl/errtest/nest0.cl | 14 + pkg/ecl/errtest/nested.cl | 12 + pkg/ecl/errtest/printvals.cl | 20 + pkg/ecl/errtest/recur0.cl | 13 + pkg/ecl/errtest/recursion.cl | 13 + pkg/ecl/errtest/sfpe.cl | 6 + pkg/ecl/errtest/spperrs.x | 25 + pkg/ecl/errtest/test_iferr.cl | 33 + pkg/ecl/errtest/zztest.cl | 24 + pkg/ecl/exec.c | 1400 ++ pkg/ecl/globals.c | 117 + pkg/ecl/gquery.c | 200 + pkg/ecl/gram.c | 1503 +++ pkg/ecl/grammar.h | 61 + pkg/ecl/grammar.l | 198 + pkg/ecl/grammar.y | 2108 +++ pkg/ecl/history.c | 1221 ++ pkg/ecl/lex.com | 12 + pkg/ecl/lex.sed | 4 + pkg/ecl/lexicon.c | 659 + pkg/ecl/lexyy.c | 900 ++ pkg/ecl/lists.c | 121 + pkg/ecl/login.cl | 97 + pkg/ecl/logout.cl | 5 + pkg/ecl/main.c | 821 ++ pkg/ecl/mem.h | 109 + pkg/ecl/mkdist | 87 + pkg/ecl/mkpkg | 206 + pkg/ecl/modes.c | 1261 ++ pkg/ecl/opcodes.c | 1400 ++ pkg/ecl/opcodes.h | 127 + pkg/ecl/operand.c | 411 + pkg/ecl/operand.h | 198 + pkg/ecl/param.c | 1397 ++ pkg/ecl/param.h | 220 + pkg/ecl/pfiles.c | 1968 +++ pkg/ecl/prcache.c | 708 + pkg/ecl/proto.h | 447 + pkg/ecl/scan.c | 342 + pkg/ecl/stack.c | 213 + pkg/ecl/tags | 481 + pkg/ecl/task.c | 569 + pkg/ecl/task.h | 226 + pkg/ecl/unop.c | 419 + pkg/ecl/uparm/history.cl | 13 + pkg/ecl/y.output | 7034 ++++++++++ pkg/ecl/ytab.c | 4644 +++++++ pkg/ecl/ytab.h | 171 + pkg/ecl/zz.cl | 3 + pkg/images/README | 10 + pkg/images/Revisions | 3680 ++++++ pkg/images/images.cl | 38 + pkg/images/images.hd | 46 + pkg/images/images.men | 7 + pkg/images/images.par | 3 + pkg/images/imcoords/Revisions | 2026 +++ pkg/images/imcoords/ccfind.par | 48 + pkg/images/imcoords/ccget.par | 36 + pkg/images/imcoords/ccmap.par | 54 + pkg/images/imcoords/ccsetwcs.par | 28 + pkg/images/imcoords/ccstd.par | 31 + pkg/images/imcoords/cctran.par | 28 + pkg/images/imcoords/ccxymatch.par | 41 + pkg/images/imcoords/doc/ccfind.hlp | 596 + pkg/images/imcoords/doc/ccget.hlp | 463 + pkg/images/imcoords/doc/ccmap.hlp | 1028 ++ pkg/images/imcoords/doc/ccsetwcs.hlp | 562 + pkg/images/imcoords/doc/ccstd.hlp | 480 + pkg/images/imcoords/doc/cctran.hlp | 412 + pkg/images/imcoords/doc/ccxymatch.hlp | 781 ++ pkg/images/imcoords/doc/hpctran.hlp | 109 + pkg/images/imcoords/doc/imcctran.hlp | 598 + pkg/images/imcoords/doc/mkcwcs.hlp | 93 + pkg/images/imcoords/doc/mkcwwcs.hlp | 110 + pkg/images/imcoords/doc/skyctran.hlp | 861 ++ pkg/images/imcoords/doc/starfind.hlp | 304 + pkg/images/imcoords/doc/wcsctran.hlp | 340 + pkg/images/imcoords/doc/wcsedit.hlp | 429 + pkg/images/imcoords/doc/wcsreset.hlp | 272 + pkg/images/imcoords/hpctran.par | 9 + pkg/images/imcoords/imcctran.par | 9 + pkg/images/imcoords/imcoords.cl | 27 + pkg/images/imcoords/imcoords.hd | 23 + pkg/images/imcoords/imcoords.men | 16 + pkg/images/imcoords/imcoords.par | 1 + pkg/images/imcoords/mkpkg | 5 + pkg/images/imcoords/skyctran.par | 29 + pkg/images/imcoords/src/ccfunc.x | 639 + pkg/images/imcoords/src/ccstd.x | 252 + pkg/images/imcoords/src/ccxytran.x | 740 ++ pkg/images/imcoords/src/healpix.x | 492 + pkg/images/imcoords/src/mkcwcs.cl | 94 + pkg/images/imcoords/src/mkcwwcs.cl | 102 + pkg/images/imcoords/src/mkpkg | 47 + pkg/images/imcoords/src/rgstr.gx | 109 + pkg/images/imcoords/src/rgstr.x | 215 + pkg/images/imcoords/src/sfconvolve.x | 398 + pkg/images/imcoords/src/sffind.x | 739 ++ pkg/images/imcoords/src/sftools.x | 68 + pkg/images/imcoords/src/skyctran.x | 2057 +++ pkg/images/imcoords/src/skycur.key | 38 + pkg/images/imcoords/src/starfind.h | 51 + pkg/images/imcoords/src/t_ccfind.x | 782 ++ pkg/images/imcoords/src/t_ccget.x | 1201 ++ pkg/images/imcoords/src/t_ccmap.x | 2079 +++ pkg/images/imcoords/src/t_ccsetwcs.x | 751 ++ pkg/images/imcoords/src/t_ccstd.x | 468 + pkg/images/imcoords/src/t_cctran.x | 374 + pkg/images/imcoords/src/t_ccxymatch.x | 576 + pkg/images/imcoords/src/t_hpctran.x | 136 + pkg/images/imcoords/src/t_imcctran.x | 922 ++ pkg/images/imcoords/src/t_skyctran.x | 221 + pkg/images/imcoords/src/t_starfind.x | 224 + pkg/images/imcoords/src/t_wcsctran.x | 643 + pkg/images/imcoords/src/t_wcsedit.x | 792 ++ pkg/images/imcoords/src/t_wcsreset.x | 142 + pkg/images/imcoords/src/ttycur.key | 49 + pkg/images/imcoords/src/wcsedit.key | 24 + pkg/images/imcoords/src/x_starfind.x | 1 + pkg/images/imcoords/starfind.par | 25 + pkg/images/imcoords/wcsctran.par | 12 + pkg/images/imcoords/wcsedit.par | 13 + pkg/images/imcoords/wcsreset.par | 5 + pkg/images/imfilter/Revisions | 2025 +++ pkg/images/imfilter/boxcar.par | 9 + pkg/images/imfilter/convolve.par | 13 + pkg/images/imfilter/doc/boxcar.hlp | 70 + pkg/images/imfilter/doc/convolve.hlp | 167 + pkg/images/imfilter/doc/fmedian.hlp | 165 + pkg/images/imfilter/doc/fmode.hlp | 176 + pkg/images/imfilter/doc/frmedian.hlp | 191 + pkg/images/imfilter/doc/frmode.hlp | 197 + pkg/images/imfilter/doc/gauss.hlp | 162 + pkg/images/imfilter/doc/gradient.hlp | 170 + pkg/images/imfilter/doc/laplace.hlp | 132 + pkg/images/imfilter/doc/median.hlp | 109 + pkg/images/imfilter/doc/mode.hlp | 119 + pkg/images/imfilter/doc/rmedian.hlp | 127 + pkg/images/imfilter/doc/rmode.hlp | 133 + pkg/images/imfilter/doc/runmed.hlp | 206 + pkg/images/imfilter/fmedian.par | 17 + pkg/images/imfilter/fmode.par | 17 + pkg/images/imfilter/frmedian.par | 19 + pkg/images/imfilter/frmode.par | 19 + pkg/images/imfilter/gauss.par | 12 + pkg/images/imfilter/gradient.par | 8 + pkg/images/imfilter/imfilter.cl | 24 + pkg/images/imfilter/imfilter.hd | 21 + pkg/images/imfilter/imfilter.men | 14 + pkg/images/imfilter/imfilter.par | 1 + pkg/images/imfilter/laplace.par | 8 + pkg/images/imfilter/median.par | 12 + pkg/images/imfilter/mkpkg | 5 + pkg/images/imfilter/mode.par | 12 + pkg/images/imfilter/rmedian.par | 14 + pkg/images/imfilter/rmode.par | 14 + pkg/images/imfilter/runmed.par | 16 + pkg/images/imfilter/src/aboxcar.x | 24 + pkg/images/imfilter/src/boxcar.x | 89 + pkg/images/imfilter/src/convolve.x | 98 + pkg/images/imfilter/src/fmd_buf.x | 124 + pkg/images/imfilter/src/fmd_hist.x | 28 + pkg/images/imfilter/src/fmd_maxmin.x | 62 + pkg/images/imfilter/src/fmedian.h | 23 + pkg/images/imfilter/src/fmedian.x | 556 + pkg/images/imfilter/src/fmode.h | 24 + pkg/images/imfilter/src/fmode.x | 578 + pkg/images/imfilter/src/frmedian.h | 17 + pkg/images/imfilter/src/frmedian.x | 180 + pkg/images/imfilter/src/frmode.h | 17 + pkg/images/imfilter/src/frmode.x | 181 + pkg/images/imfilter/src/med_buf.x | 65 + pkg/images/imfilter/src/med_sort.x | 168 + pkg/images/imfilter/src/med_utils.x | 104 + pkg/images/imfilter/src/median.h | 15 + pkg/images/imfilter/src/median.x | 866 ++ pkg/images/imfilter/src/mkpkg | 43 + pkg/images/imfilter/src/mode.h | 16 + pkg/images/imfilter/src/mode.x | 903 ++ pkg/images/imfilter/src/radcnv.x | 95 + pkg/images/imfilter/src/rmedian.h | 9 + pkg/images/imfilter/src/rmedian.x | 126 + pkg/images/imfilter/src/rmode.h | 9 + pkg/images/imfilter/src/rmode.x | 131 + pkg/images/imfilter/src/runmed.x | 506 + pkg/images/imfilter/src/t_boxcar.x | 92 + pkg/images/imfilter/src/t_convolve.x | 302 + pkg/images/imfilter/src/t_fmedian.x | 148 + pkg/images/imfilter/src/t_fmode.x | 148 + pkg/images/imfilter/src/t_frmedian.x | 194 + pkg/images/imfilter/src/t_frmode.x | 194 + pkg/images/imfilter/src/t_gauss.x | 297 + pkg/images/imfilter/src/t_gradient.x | 245 + pkg/images/imfilter/src/t_laplace.x | 177 + pkg/images/imfilter/src/t_median.x | 126 + pkg/images/imfilter/src/t_mode.x | 125 + pkg/images/imfilter/src/t_rmedian.x | 179 + pkg/images/imfilter/src/t_rmode.x | 179 + pkg/images/imfilter/src/t_runmed.x | 62 + pkg/images/imfilter/src/xyconvolve.x | 124 + pkg/images/imfit/Revisions | 2025 +++ pkg/images/imfit/doc/fit1d.hlp | 177 + pkg/images/imfit/doc/imsurfit.hlp | 226 + pkg/images/imfit/doc/lineclean.hlp | 129 + pkg/images/imfit/fit1d.par | 16 + pkg/images/imfit/imfit.cl | 13 + pkg/images/imfit/imfit.hd | 10 + pkg/images/imfit/imfit.men | 3 + pkg/images/imfit/imfit.par | 1 + pkg/images/imfit/imsurfit.par | 24 + pkg/images/imfit/lineclean.par | 13 + pkg/images/imfit/mkpkg | 5 + pkg/images/imfit/src/fit1d.x | 597 + pkg/images/imfit/src/imsurfit.h | 40 + pkg/images/imfit/src/imsurfit.x | 1172 ++ pkg/images/imfit/src/mkpkg | 15 + pkg/images/imfit/src/pixlist.h | 11 + pkg/images/imfit/src/pixlist.x | 369 + pkg/images/imfit/src/ranges.x | 524 + pkg/images/imfit/src/t_imsurfit.x | 400 + pkg/images/imfit/src/t_lineclean.x | 270 + pkg/images/imgeom/Revisions | 2026 +++ pkg/images/imgeom/blkavg.par | 12 + pkg/images/imgeom/blkrep.par | 11 + pkg/images/imgeom/doc/blkavg.hlp | 65 + pkg/images/imgeom/doc/blkrep.hlp | 103 + pkg/images/imgeom/doc/im3dtran.hlp | 94 + pkg/images/imgeom/doc/imlintran.hlp | 184 + pkg/images/imgeom/doc/imshift.hlp | 125 + pkg/images/imgeom/doc/imtrans.hlp | 69 + pkg/images/imgeom/doc/magnify.hlp | 202 + pkg/images/imgeom/doc/rotate.hlp | 164 + pkg/images/imgeom/doc/shiftlines.hlp | 119 + pkg/images/imgeom/im3dtran.par | 9 + pkg/images/imgeom/imgeom.cl | 30 + pkg/images/imgeom/imgeom.hd | 16 + pkg/images/imgeom/imgeom.men | 9 + pkg/images/imgeom/imgeom.par | 1 + pkg/images/imgeom/imlintran.cl | 50 + pkg/images/imgeom/imlintran.par | 30 + pkg/images/imgeom/imshift.par | 11 + pkg/images/imgeom/imtranspose.par | 3 + pkg/images/imgeom/junk.cl | 50 + pkg/images/imgeom/magnify.par | 17 + pkg/images/imgeom/mkpkg | 5 + pkg/images/imgeom/rotate.cl | 43 + pkg/images/imgeom/rotate.par | 24 + pkg/images/imgeom/shiftlines.par | 9 + pkg/images/imgeom/src/blkav.gx | 131 + pkg/images/imgeom/src/blkcomp.x | 38 + pkg/images/imgeom/src/blkrp.gx | 103 + pkg/images/imgeom/src/generic/blkav.x | 361 + pkg/images/imgeom/src/generic/blkrp.x | 397 + pkg/images/imgeom/src/generic/im3dtran.x | 583 + pkg/images/imgeom/src/generic/imtrans.x | 93 + pkg/images/imgeom/src/generic/mkpkg | 13 + pkg/images/imgeom/src/im3dtran.gx | 98 + pkg/images/imgeom/src/imtrans.gx | 18 + pkg/images/imgeom/src/mkpkg | 35 + pkg/images/imgeom/src/shiftlines.x | 279 + pkg/images/imgeom/src/t_blkavg.x | 115 + pkg/images/imgeom/src/t_blkrep.x | 96 + pkg/images/imgeom/src/t_im3dtran.x | 719 ++ pkg/images/imgeom/src/t_imshift.x | 530 + pkg/images/imgeom/src/t_imtrans.x | 299 + pkg/images/imgeom/src/t_magnify.x | 624 + pkg/images/imgeom/src/t_shiftlines.x | 102 + pkg/images/immatch/Revisions | 2025 +++ pkg/images/immatch/doc/geomap.hlp | 435 + pkg/images/immatch/doc/geotran.hlp | 320 + pkg/images/immatch/doc/geoxytran.hlp | 408 + pkg/images/immatch/doc/gregister.hlp | 265 + pkg/images/immatch/doc/imalign.hlp | 316 + pkg/images/immatch/doc/imcentroid.hlp | 257 + pkg/images/immatch/doc/imcombine.hlp | 1471 +++ pkg/images/immatch/doc/linmatch.hlp | 699 + pkg/images/immatch/doc/psfmatch.hlp | 595 + pkg/images/immatch/doc/skymap.hlp | 642 + pkg/images/immatch/doc/skyxymatch.hlp | 406 + pkg/images/immatch/doc/sregister.hlp | 779 ++ pkg/images/immatch/doc/wcscopy.hlp | 80 + pkg/images/immatch/doc/wcsmap.hlp | 619 + pkg/images/immatch/doc/wcsxymatch.hlp | 314 + pkg/images/immatch/doc/wregister.hlp | 761 ++ pkg/images/immatch/doc/xregister.hlp | 707 + pkg/images/immatch/doc/xyxymatch.hlp | 468 + pkg/images/immatch/geomap.par | 32 + pkg/images/immatch/geotran.par | 45 + pkg/images/immatch/geoxytran.par | 28 + pkg/images/immatch/gregister.cl | 51 + pkg/images/immatch/gregister.par | 33 + pkg/images/immatch/imalign.cl | 119 + pkg/images/immatch/imalign.par | 28 + pkg/images/immatch/imcentroid.par | 16 + pkg/images/immatch/imcombine.par | 43 + pkg/images/immatch/immatch.cl | 39 + pkg/images/immatch/immatch.hd | 32 + pkg/images/immatch/immatch.men | 18 + pkg/images/immatch/immatch.par | 1 + pkg/images/immatch/linmatch.par | 30 + pkg/images/immatch/mkpkg | 5 + pkg/images/immatch/psfmatch.par | 40 + pkg/images/immatch/skymap.cl | 114 + pkg/images/immatch/skyxymatch.par | 26 + pkg/images/immatch/src/geometry/geofunc.gx | 250 + pkg/images/immatch/src/geometry/geofunc.x | 340 + pkg/images/immatch/src/geometry/geotimtran.x | 543 + pkg/images/immatch/src/geometry/geotran.h | 52 + pkg/images/immatch/src/geometry/geotran.x | 1752 +++ pkg/images/immatch/src/geometry/geoxytran.gx | 327 + pkg/images/immatch/src/geometry/geoxytran.x | 446 + pkg/images/immatch/src/geometry/mkpkg | 34 + pkg/images/immatch/src/geometry/t_geomap.gx | 921 ++ pkg/images/immatch/src/geometry/t_geomap.x | 1509 +++ pkg/images/immatch/src/geometry/t_geotran.x | 880 ++ pkg/images/immatch/src/geometry/t_geoxytran.x | 343 + pkg/images/immatch/src/geometry/trinvert.x | 163 + pkg/images/immatch/src/imcombine/imcombine.par | 43 + pkg/images/immatch/src/imcombine/mkpkg | 20 + pkg/images/immatch/src/imcombine/src/Revisions | 36 + .../immatch/src/imcombine/src/generic/icaclip.x | 2207 ++++ .../immatch/src/imcombine/src/generic/icaverage.x | 424 + .../immatch/src/imcombine/src/generic/iccclip.x | 1791 +++ .../immatch/src/imcombine/src/generic/icgdata.x | 1531 +++ .../immatch/src/imcombine/src/generic/icgrow.x | 263 + .../immatch/src/imcombine/src/generic/icmedian.x | 753 ++ .../immatch/src/imcombine/src/generic/icmm.x | 645 + .../immatch/src/imcombine/src/generic/icnmodel.x | 528 + .../immatch/src/imcombine/src/generic/icomb.x | 2198 ++++ .../immatch/src/imcombine/src/generic/icpclip.x | 879 ++ .../immatch/src/imcombine/src/generic/icquad.x | 476 + .../immatch/src/imcombine/src/generic/icsclip.x | 1923 +++ .../immatch/src/imcombine/src/generic/icsigma.x | 434 + .../immatch/src/imcombine/src/generic/icsort.x | 1096 ++ .../immatch/src/imcombine/src/generic/icstat.x | 892 ++ pkg/images/immatch/src/imcombine/src/generic/mkpkg | 27 + .../immatch/src/imcombine/src/generic/xtimmap.com | 9 + .../immatch/src/imcombine/src/generic/xtimmap.x | 1207 ++ pkg/images/immatch/src/imcombine/src/icaclip.gx | 575 + pkg/images/immatch/src/imcombine/src/icaverage.gx | 120 + pkg/images/immatch/src/imcombine/src/iccclip.gx | 471 + pkg/images/immatch/src/imcombine/src/icemask.x | 115 + pkg/images/immatch/src/imcombine/src/icgdata.gx | 396 + pkg/images/immatch/src/imcombine/src/icgrow.gx | 135 + pkg/images/immatch/src/imcombine/src/icgscale.x | 88 + pkg/images/immatch/src/imcombine/src/ichdr.x | 72 + pkg/images/immatch/src/imcombine/src/icimstack.x | 186 + pkg/images/immatch/src/imcombine/src/iclog.x | 431 + pkg/images/immatch/src/imcombine/src/icmask.com | 8 + pkg/images/immatch/src/imcombine/src/icmask.h | 12 + pkg/images/immatch/src/imcombine/src/icmask.x | 685 + pkg/images/immatch/src/imcombine/src/icmedian.gx | 246 + pkg/images/immatch/src/imcombine/src/icmm.gx | 189 + pkg/images/immatch/src/imcombine/src/icnmodel.gx | 147 + pkg/images/immatch/src/imcombine/src/icomb.gx | 761 ++ pkg/images/immatch/src/imcombine/src/icombine.com | 45 + pkg/images/immatch/src/imcombine/src/icombine.h | 63 + pkg/images/immatch/src/imcombine/src/icombine.x | 520 + pkg/images/immatch/src/imcombine/src/icpclip.gx | 233 + pkg/images/immatch/src/imcombine/src/icpmmap.x | 34 + pkg/images/immatch/src/imcombine/src/icquad.gx | 133 + pkg/images/immatch/src/imcombine/src/icrmasks.x | 41 + pkg/images/immatch/src/imcombine/src/icscale.x | 351 + pkg/images/immatch/src/imcombine/src/icsclip.gx | 504 + pkg/images/immatch/src/imcombine/src/icsection.x | 94 + pkg/images/immatch/src/imcombine/src/icsetout.x | 332 + pkg/images/immatch/src/imcombine/src/icsigma.gx | 122 + pkg/images/immatch/src/imcombine/src/icsort.gx | 386 + pkg/images/immatch/src/imcombine/src/icstat.gx | 238 + pkg/images/immatch/src/imcombine/src/mkpkg | 67 + pkg/images/immatch/src/imcombine/src/tymax.x | 27 + pkg/images/immatch/src/imcombine/src/xtimmap.gx | 634 + pkg/images/immatch/src/imcombine/src/xtprocid.x | 38 + pkg/images/immatch/src/imcombine/t_imcombine.x | 230 + pkg/images/immatch/src/imcombine/x_imcombine.x | 1 + pkg/images/immatch/src/linmatch/linmatch.h | 298 + pkg/images/immatch/src/linmatch/linmatch.key | 51 + pkg/images/immatch/src/linmatch/lsqfit.h | 18 + pkg/images/immatch/src/linmatch/mkpkg | 21 + pkg/images/immatch/src/linmatch/rglcolon.x | 564 + pkg/images/immatch/src/linmatch/rgldbio.x | 225 + pkg/images/immatch/src/linmatch/rgldelete.x | 993 ++ pkg/images/immatch/src/linmatch/rgliscale.x | 593 + pkg/images/immatch/src/linmatch/rglpars.x | 104 + pkg/images/immatch/src/linmatch/rglplot.x | 1592 +++ pkg/images/immatch/src/linmatch/rglregions.x | 1084 ++ pkg/images/immatch/src/linmatch/rglscale.x | 1337 ++ pkg/images/immatch/src/linmatch/rglshow.x | 107 + pkg/images/immatch/src/linmatch/rglsqfit.x | 443 + pkg/images/immatch/src/linmatch/rgltools.x | 1017 ++ pkg/images/immatch/src/linmatch/t_linmatch.x | 544 + pkg/images/immatch/src/listmatch/mkpkg | 12 + pkg/images/immatch/src/listmatch/t_imctroid.x | 1016 ++ pkg/images/immatch/src/listmatch/t_xyxymatch.x | 406 + pkg/images/immatch/src/mkpkg | 11 + pkg/images/immatch/src/psfmatch/mkpkg | 21 + pkg/images/immatch/src/psfmatch/psfmatch.h | 274 + pkg/images/immatch/src/psfmatch/psfmatch.key | 50 + pkg/images/immatch/src/psfmatch/rgpbckgrd.x | 70 + pkg/images/immatch/src/psfmatch/rgpcolon.x | 501 + pkg/images/immatch/src/psfmatch/rgpconvolve.x | 106 + pkg/images/immatch/src/psfmatch/rgpfft.x | 443 + pkg/images/immatch/src/psfmatch/rgpfilter.x | 502 + pkg/images/immatch/src/psfmatch/rgpisfm.x | 556 + pkg/images/immatch/src/psfmatch/rgppars.x | 124 + pkg/images/immatch/src/psfmatch/rgpregions.x | 464 + pkg/images/immatch/src/psfmatch/rgpsfm.x | 815 ++ pkg/images/immatch/src/psfmatch/rgpshow.x | 116 + pkg/images/immatch/src/psfmatch/rgptools.x | 641 + pkg/images/immatch/src/psfmatch/t_psfmatch.x | 365 + pkg/images/immatch/src/wcsmatch/mkpkg | 14 + pkg/images/immatch/src/wcsmatch/rgmatchio.x | 77 + pkg/images/immatch/src/wcsmatch/t_skyxymatch.x | 690 + pkg/images/immatch/src/wcsmatch/t_wcscopy.x | 199 + pkg/images/immatch/src/wcsmatch/t_wcsxymatch.x | 787 ++ pkg/images/immatch/src/wcsmatch/wcsxymatch.h | 15 + pkg/images/immatch/src/xregister/mkpkg | 25 + pkg/images/immatch/src/xregister/oxregister.key | 33 + pkg/images/immatch/src/xregister/rgxbckgrd.x | 63 + pkg/images/immatch/src/xregister/rgxcolon.x | 508 + pkg/images/immatch/src/xregister/rgxcorr.x | 1034 ++ pkg/images/immatch/src/xregister/rgxdbio.x | 290 + pkg/images/immatch/src/xregister/rgxfft.x | 179 + pkg/images/immatch/src/xregister/rgxfit.x | 814 ++ pkg/images/immatch/src/xregister/rgxgpars.x | 68 + pkg/images/immatch/src/xregister/rgxicorr.x | 583 + pkg/images/immatch/src/xregister/rgximshift.x | 391 + pkg/images/immatch/src/xregister/rgxplot.x | 317 + pkg/images/immatch/src/xregister/rgxppars.x | 49 + pkg/images/immatch/src/xregister/rgxregions.x | 459 + pkg/images/immatch/src/xregister/rgxshow.x | 172 + pkg/images/immatch/src/xregister/rgxtools.x | 685 + pkg/images/immatch/src/xregister/rgxtransform.x | 446 + pkg/images/immatch/src/xregister/t_xregister.x | 440 + pkg/images/immatch/src/xregister/xregister.h | 250 + pkg/images/immatch/src/xregister/xregister.key | 47 + pkg/images/immatch/sregister.cl | 151 + pkg/images/immatch/wcscopy.par | 5 + pkg/images/immatch/wcsmap.cl | 111 + pkg/images/immatch/wcsxymatch.par | 25 + pkg/images/immatch/wregister.cl | 148 + pkg/images/immatch/xregister.par | 42 + pkg/images/immatch/xyxymatch.par | 36 + pkg/images/imutil/Revisions | 2045 +++ pkg/images/imutil/_imaxes.par | 9 + pkg/images/imutil/chpixtype.par | 8 + pkg/images/imutil/doc/chpix.hlp | 64 + pkg/images/imutil/doc/hedit.hlp | 375 + pkg/images/imutil/doc/hselect.hlp | 103 + pkg/images/imutil/doc/imarith.hlp | 218 + pkg/images/imutil/doc/imcopy.hlp | 91 + pkg/images/imutil/doc/imdelete.hlp | 55 + pkg/images/imutil/doc/imdivide.hlp | 65 + pkg/images/imutil/doc/imexpr.hlp | 447 + pkg/images/imutil/doc/imfunction.hlp | 130 + pkg/images/imutil/doc/imgets.hlp | 70 + pkg/images/imutil/doc/imheader.hlp | 62 + pkg/images/imutil/doc/imhistogram.hlp | 111 + pkg/images/imutil/doc/imjoin.hlp | 70 + pkg/images/imutil/doc/imrename.hlp | 50 + pkg/images/imutil/doc/imreplace.hlp | 72 + pkg/images/imutil/doc/imslice.hlp | 58 + pkg/images/imutil/doc/imstack.hlp | 56 + pkg/images/imutil/doc/imstat.hlp | 121 + pkg/images/imutil/doc/imsum.hlp | 132 + pkg/images/imutil/doc/imtile.hlp | 151 + pkg/images/imutil/doc/listpixels.hlp | 191 + pkg/images/imutil/doc/minmax.hlp | 84 + pkg/images/imutil/doc/nhedit.hlp | 499 + pkg/images/imutil/doc/sections.hlp | 119 + pkg/images/imutil/hedit.par | 9 + pkg/images/imutil/hselect.par | 4 + pkg/images/imutil/imarith.par | 11 + pkg/images/imutil/imcopy.par | 6 + pkg/images/imutil/imdelete.par | 7 + pkg/images/imutil/imdivide.par | 10 + pkg/images/imutil/imexpr.par | 44 + pkg/images/imutil/imfunction.par | 6 + pkg/images/imutil/imgets.par | 3 + pkg/images/imutil/imheader.par | 6 + pkg/images/imutil/imhistogram.par | 13 + pkg/images/imutil/imjoin.par | 5 + pkg/images/imutil/imrename.par | 3 + pkg/images/imutil/imreplace.par | 8 + pkg/images/imutil/imslice.par | 7 + pkg/images/imutil/imstack.par | 7 + pkg/images/imutil/imstatistics.par | 10 + pkg/images/imutil/imsum.par | 10 + pkg/images/imutil/imtile.par | 21 + pkg/images/imutil/imutil.cl | 35 + pkg/images/imutil/imutil.hd | 31 + pkg/images/imutil/imutil.men | 25 + pkg/images/imutil/imutil.par | 1 + pkg/images/imutil/listpixels.par | 4 + pkg/images/imutil/minmax.par | 10 + pkg/images/imutil/mkpkg | 5 + pkg/images/imutil/nhedit.par | 14 + pkg/images/imutil/sections.par | 5 + pkg/images/imutil/src/generic/imaadd.x | 255 + pkg/images/imutil/src/generic/imadiv.x | 347 + pkg/images/imutil/src/generic/imamax.x | 212 + pkg/images/imutil/src/generic/imamin.x | 212 + pkg/images/imutil/src/generic/imamul.x | 257 + pkg/images/imutil/src/generic/imanl.x | 159 + pkg/images/imutil/src/generic/imasub.x | 252 + pkg/images/imutil/src/generic/imfuncs.x | 1613 +++ pkg/images/imutil/src/generic/imjoin.x | 527 + pkg/images/imutil/src/generic/imrep.x | 1423 ++ pkg/images/imutil/src/generic/imsum.x | 1902 +++ pkg/images/imutil/src/generic/mkpkg | 21 + pkg/images/imutil/src/getcmd.x | 406 + pkg/images/imutil/src/gettok.h | 22 + pkg/images/imutil/src/gettok.x | 922 ++ pkg/images/imutil/src/hedit.x | 806 ++ pkg/images/imutil/src/hselect.x | 132 + pkg/images/imutil/src/iegsym.x | 37 + pkg/images/imutil/src/imaadd.gx | 55 + pkg/images/imutil/src/imadiv.gx | 75 + pkg/images/imutil/src/imamax.gx | 48 + pkg/images/imutil/src/imamin.gx | 48 + pkg/images/imutil/src/imamul.gx | 57 + pkg/images/imutil/src/imanl.gx | 47 + pkg/images/imutil/src/imasub.gx | 56 + pkg/images/imutil/src/imdelete.x | 85 + pkg/images/imutil/src/imexpr.gx | 1183 ++ pkg/images/imutil/src/imexpr.x | 1263 ++ pkg/images/imutil/src/imfuncs.gx | 786 ++ pkg/images/imutil/src/imfunction.x | 306 + pkg/images/imutil/src/imgets.x | 53 + pkg/images/imutil/src/imheader.x | 303 + pkg/images/imutil/src/imhistogram.x | 332 + pkg/images/imutil/src/imjoin.gx | 92 + pkg/images/imutil/src/imminmax.x | 74 + pkg/images/imutil/src/imrep.gx | 346 + pkg/images/imutil/src/imstat.h | 62 + pkg/images/imutil/src/imsum.gx | 398 + pkg/images/imutil/src/imsum.h | 4 + pkg/images/imutil/src/imtile.h | 55 + pkg/images/imutil/src/listpixels.x | 216 + pkg/images/imutil/src/minmax.x | 313 + pkg/images/imutil/src/mkpkg | 81 + pkg/images/imutil/src/nhedit.x | 1101 ++ pkg/images/imutil/src/t_chpix.x | 238 + pkg/images/imutil/src/t_imarith.x | 489 + pkg/images/imutil/src/t_imaxes.x | 33 + pkg/images/imutil/src/t_imcopy.x | 82 + pkg/images/imutil/src/t_imdivide.x | 132 + pkg/images/imutil/src/t_imjoin.x | 272 + pkg/images/imutil/src/t_imrename.x | 100 + pkg/images/imutil/src/t_imreplace.x | 83 + pkg/images/imutil/src/t_imslice.x | 472 + pkg/images/imutil/src/t_imstack.x | 300 + pkg/images/imutil/src/t_imstat.x | 1213 ++ pkg/images/imutil/src/t_imsum.x | 320 + pkg/images/imutil/src/t_imtile.x | 619 + pkg/images/imutil/src/t_minmax.x | 192 + pkg/images/imutil/src/t_sections.x | 39 + pkg/images/lib/coomap.key | 33 + pkg/images/lib/geofit.gx | 1605 +++ pkg/images/lib/geofit.x | 2539 ++++ pkg/images/lib/geofiti.x | 2521 ++++ pkg/images/lib/geogmap.gx | 494 + pkg/images/lib/geogmap.h | 37 + pkg/images/lib/geogmap.x | 905 ++ pkg/images/lib/geogmapi.x | 905 ++ pkg/images/lib/geograph.gx | 1379 ++ pkg/images/lib/geograph.x | 1740 +++ pkg/images/lib/geomap.h | 109 + pkg/images/lib/geomap.key | 31 + pkg/images/lib/geoset.x | 61 + pkg/images/lib/imcopy.x | 106 + pkg/images/lib/liststr.gx | 427 + pkg/images/lib/liststr.x | 766 ++ pkg/images/lib/mkpkg | 72 + pkg/images/lib/rgbckgrd.x | 661 + pkg/images/lib/rgccwcs.x | 221 + pkg/images/lib/rgcontour.x | 475 + pkg/images/lib/rgfft.x | 269 + pkg/images/lib/rglltran.x | 42 + pkg/images/lib/rgmerge.x | 1023 ++ pkg/images/lib/rgsort.x | 162 + pkg/images/lib/rgtransform.x | 947 ++ pkg/images/lib/rgwrdstr.x | 53 + pkg/images/lib/rgxymatch.x | 97 + pkg/images/lib/xymatch.x | 175 + pkg/images/lib/xyxymatch.h | 35 + pkg/images/lib/zzdebug.x | 430 + pkg/images/mkpkg | 33 + pkg/images/notes | 341 + pkg/images/tv/Revisions | 996 ++ pkg/images/tv/_dcontrol.par | 18 + pkg/images/tv/cimexam.par | 22 + pkg/images/tv/display.par | 30 + pkg/images/tv/display/README | 15 + pkg/images/tv/display/ace.h | 38 + pkg/images/tv/display/display.h | 42 + pkg/images/tv/display/dsmap.x | 33 + pkg/images/tv/display/dspmmap.x | 20 + pkg/images/tv/display/dsulut.x | 141 + pkg/images/tv/display/findz.x | 62 + pkg/images/tv/display/gwindow.h | 49 + pkg/images/tv/display/iis.com | 25 + pkg/images/tv/display/iis.h | 121 + pkg/images/tv/display/iisblk.x | 40 + pkg/images/tv/display/iiscls.x | 24 + pkg/images/tv/display/iisers.x | 28 + pkg/images/tv/display/iisflu.x | 24 + pkg/images/tv/display/iisgop.x | 14 + pkg/images/tv/display/iishdr.x | 30 + pkg/images/tv/display/iisio.x | 43 + pkg/images/tv/display/iismtc.x | 21 + pkg/images/tv/display/iisofm.x | 183 + pkg/images/tv/display/iisopn.x | 76 + pkg/images/tv/display/iispio.x | 97 + pkg/images/tv/display/iisrcr.x | 32 + pkg/images/tv/display/iisrd.x | 42 + pkg/images/tv/display/iisrgb.x | 32 + pkg/images/tv/display/iissfr.x | 15 + pkg/images/tv/display/iisstt.x | 29 + pkg/images/tv/display/iiswcr.x | 20 + pkg/images/tv/display/iiswnd.x | 117 + pkg/images/tv/display/iiswr.x | 48 + pkg/images/tv/display/iiswt.x | 19 + pkg/images/tv/display/iiszm.x | 38 + pkg/images/tv/display/imd.com | 7 + pkg/images/tv/display/imdgcur.x | 37 + pkg/images/tv/display/imdgetwcs.x | 188 + pkg/images/tv/display/imdmapfr.x | 108 + pkg/images/tv/display/imdmapping.x | 194 + pkg/images/tv/display/imdopen.x | 16 + pkg/images/tv/display/imdputwcs.x | 139 + pkg/images/tv/display/imdrcur.x | 117 + pkg/images/tv/display/imdrcuro.x | 206 + pkg/images/tv/display/imdsetwcs.x | 32 + pkg/images/tv/display/imdwcs.x | 118 + pkg/images/tv/display/imdwcsver.x | 65 + pkg/images/tv/display/maskcolor.x | 478 + pkg/images/tv/display/maxmin.x | 54 + pkg/images/tv/display/mkpkg | 79 + pkg/images/tv/display/sigl2.x | 976 ++ pkg/images/tv/display/sigm2.x | 1110 ++ pkg/images/tv/display/t_dcontrol.x | 193 + pkg/images/tv/display/t_display.x | 885 ++ pkg/images/tv/display/zardim.x | 21 + pkg/images/tv/display/zawrim.x | 21 + pkg/images/tv/display/zawtim.x | 19 + pkg/images/tv/display/zblkim.x | 23 + pkg/images/tv/display/zclrim.x | 18 + pkg/images/tv/display/zclsim.x | 22 + pkg/images/tv/display/zdisplay.h | 6 + pkg/images/tv/display/zersim.x | 18 + pkg/images/tv/display/zfrmim.x | 19 + pkg/images/tv/display/zmapim.x | 19 + pkg/images/tv/display/zmtcim.x | 18 + pkg/images/tv/display/zopnim.x | 19 + pkg/images/tv/display/zrcrim.x | 19 + pkg/images/tv/display/zrgbim.x | 19 + pkg/images/tv/display/zrmim.x | 19 + pkg/images/tv/display/zscale.x | 623 + pkg/images/tv/display/zsttim.x | 26 + pkg/images/tv/display/zwndim.x | 31 + pkg/images/tv/display/zzdebug.x | 165 + pkg/images/tv/doc/Tv.hlp | 357 + pkg/images/tv/doc/bpmedit.hlp | 155 + pkg/images/tv/doc/display.hlp | 555 + pkg/images/tv/doc/imedit.hlp | 493 + pkg/images/tv/doc/imexamine.hlp | 1043 ++ pkg/images/tv/doc/tvmark.hlp | 405 + pkg/images/tv/doc/wcslab.hlp | 698 + pkg/images/tv/eimexam.par | 24 + pkg/images/tv/himexam.par | 29 + pkg/images/tv/iis/README | 3 + pkg/images/tv/iis/blink.cl | 19 + pkg/images/tv/iis/blink.par | 5 + pkg/images/tv/iis/cv.par | 4 + pkg/images/tv/iis/cvl.par | 25 + pkg/images/tv/iis/doc/Cv.spc.hlp | 286 + pkg/images/tv/iis/doc/blink.hlp | 46 + pkg/images/tv/iis/doc/cv.doc | 332 + pkg/images/tv/iis/doc/cv.hlp | 341 + pkg/images/tv/iis/doc/cv.ms | 332 + pkg/images/tv/iis/doc/cvl.hlp | 287 + pkg/images/tv/iis/doc/erase.hlp | 26 + pkg/images/tv/iis/doc/frame.hlp | 24 + pkg/images/tv/iis/doc/lumatch.hlp | 28 + pkg/images/tv/iis/doc/monochrome.hlp | 18 + pkg/images/tv/iis/doc/pseudocolor.hlp | 41 + pkg/images/tv/iis/doc/rgb.hlp | 33 + pkg/images/tv/iis/doc/window.hlp | 38 + pkg/images/tv/iis/doc/zoom.hlp | 31 + pkg/images/tv/iis/erase.cl | 10 + pkg/images/tv/iis/erase.par | 2 + pkg/images/tv/iis/frame.cl | 5 + pkg/images/tv/iis/giis.par | 7 + pkg/images/tv/iis/ids/doc/Imdis.hlp | 793 ++ pkg/images/tv/iis/ids/doc/Note.misc | 8 + pkg/images/tv/iis/ids/doc/Note.pixel | 106 + pkg/images/tv/iis/ids/doc/file.doc | 90 + pkg/images/tv/iis/ids/doc/iis.doc | 172 + pkg/images/tv/iis/ids/font.com | 207 + pkg/images/tv/iis/ids/font.h | 29 + pkg/images/tv/iis/ids/idscancel.x | 19 + pkg/images/tv/iis/ids/idschars.x | 20 + pkg/images/tv/iis/ids/idsclear.x | 16 + pkg/images/tv/iis/ids/idsclose.x | 19 + pkg/images/tv/iis/ids/idsclosews.x | 15 + pkg/images/tv/iis/ids/idscround.x | 61 + pkg/images/tv/iis/ids/idsdrawch.x | 67 + pkg/images/tv/iis/ids/idsescape.x | 115 + pkg/images/tv/iis/ids/idsfa.x | 16 + pkg/images/tv/iis/ids/idsfaset.x | 18 + pkg/images/tv/iis/ids/idsflush.x | 18 + pkg/images/tv/iis/ids/idsfont.x | 40 + pkg/images/tv/iis/ids/idsgcell.x | 170 + pkg/images/tv/iis/ids/idsgcur.x | 33 + pkg/images/tv/iis/ids/idsinit.x | 172 + pkg/images/tv/iis/ids/idsline.x | 30 + pkg/images/tv/iis/ids/idslutfill.x | 36 + pkg/images/tv/iis/ids/idsopen.x | 58 + pkg/images/tv/iis/ids/idsopenws.x | 120 + pkg/images/tv/iis/ids/idspcell.x | 178 + pkg/images/tv/iis/ids/idspl.x | 61 + pkg/images/tv/iis/ids/idsplset.x | 21 + pkg/images/tv/iis/ids/idspm.x | 56 + pkg/images/tv/iis/ids/idspmset.x | 19 + pkg/images/tv/iis/ids/idspoint.x | 65 + pkg/images/tv/iis/ids/idsreset.x | 56 + pkg/images/tv/iis/ids/idsrestore.x | 84 + pkg/images/tv/iis/ids/idssave.x | 82 + pkg/images/tv/iis/ids/idsscur.x | 12 + pkg/images/tv/iis/ids/idsstream.x | 16 + pkg/images/tv/iis/ids/idstx.x | 428 + pkg/images/tv/iis/ids/idstxset.x | 30 + pkg/images/tv/iis/ids/idsvector.x | 122 + pkg/images/tv/iis/ids/mkpkg | 43 + pkg/images/tv/iis/ids/testcode/README | 2 + pkg/images/tv/iis/ids/testcode/box.x | 83 + pkg/images/tv/iis/ids/testcode/boxin.x | 98 + pkg/images/tv/iis/ids/testcode/crin.x | 130 + pkg/images/tv/iis/ids/testcode/grey.x | 90 + pkg/images/tv/iis/ids/testcode/grin.x | 98 + pkg/images/tv/iis/ids/testcode/scr.x | 130 + pkg/images/tv/iis/ids/testcode/scrin.x | 130 + pkg/images/tv/iis/ids/testcode/sn.x | 192 + pkg/images/tv/iis/ids/testcode/t_giis.x | 67 + pkg/images/tv/iis/ids/testcode/zm.x | 64 + pkg/images/tv/iis/ids/testcode/zmin.x | 84 + pkg/images/tv/iis/ids/testcode/zztest.x | 81 + pkg/images/tv/iis/iis.cl | 22 + pkg/images/tv/iis/iis.hd | 16 + pkg/images/tv/iis/iis.men | 11 + pkg/images/tv/iis/iis.par | 1 + pkg/images/tv/iis/iism70/README | 5 + pkg/images/tv/iis/iism70/idsexpand.x | 30 + pkg/images/tv/iis/iism70/iis.com | 12 + pkg/images/tv/iis/iism70/iis.h | 120 + pkg/images/tv/iis/iism70/iisbutton.x | 44 + pkg/images/tv/iis/iism70/iiscls.x | 27 + pkg/images/tv/iis/iism70/iiscursor.x | 108 + pkg/images/tv/iis/iism70/iishdr.x | 31 + pkg/images/tv/iis/iism70/iishisto.x | 53 + pkg/images/tv/iis/iism70/iisifm.x | 51 + pkg/images/tv/iis/iism70/iisio.x | 35 + pkg/images/tv/iis/iism70/iislut.x | 67 + pkg/images/tv/iis/iism70/iismatch.x | 76 + pkg/images/tv/iis/iism70/iisminmax.x | 87 + pkg/images/tv/iis/iism70/iisoffset.x | 67 + pkg/images/tv/iis/iism70/iisofm.x | 53 + pkg/images/tv/iis/iism70/iisopn.x | 35 + pkg/images/tv/iis/iism70/iispack.x | 21 + pkg/images/tv/iis/iism70/iispio.x | 65 + pkg/images/tv/iis/iism70/iisrange.x | 97 + pkg/images/tv/iis/iism70/iisrd.x | 51 + pkg/images/tv/iis/iism70/iisscroll.x | 101 + pkg/images/tv/iis/iism70/iissplit.x | 68 + pkg/images/tv/iis/iism70/iistball.x | 41 + pkg/images/tv/iis/iism70/iiswr.x | 51 + pkg/images/tv/iis/iism70/iiswt.x | 18 + pkg/images/tv/iis/iism70/iiszoom.x | 98 + pkg/images/tv/iis/iism70/mkpkg | 58 + pkg/images/tv/iis/iism70/zardim.x | 16 + pkg/images/tv/iis/iism70/zawrim.x | 14 + pkg/images/tv/iis/iism70/zawtim.x | 16 + pkg/images/tv/iis/iism70/zclear.x | 33 + pkg/images/tv/iis/iism70/zclsim.x | 13 + pkg/images/tv/iis/iism70/zcontrol.x | 116 + pkg/images/tv/iis/iism70/zcursor_read.x | 96 + pkg/images/tv/iis/iism70/zcursor_set.x | 100 + pkg/images/tv/iis/iism70/zdisplay_g.x | 91 + pkg/images/tv/iis/iism70/zdisplay_i.x | 124 + pkg/images/tv/iis/iism70/zinit.x | 45 + pkg/images/tv/iis/iism70/zopnim.x | 17 + pkg/images/tv/iis/iism70/zreset.x | 164 + pkg/images/tv/iis/iism70/zrestore.x | 30 + pkg/images/tv/iis/iism70/zsave.x | 30 + pkg/images/tv/iis/iism70/zseek.x | 21 + pkg/images/tv/iis/iism70/zsetup.x | 34 + pkg/images/tv/iis/iism70/zsnap.com | 26 + pkg/images/tv/iis/iism70/zsnap.x | 239 + pkg/images/tv/iis/iism70/zsnapinit.x | 314 + pkg/images/tv/iis/iism70/zsttim.x | 14 + pkg/images/tv/iis/lib/ids.com | 25 + pkg/images/tv/iis/lib/ids.h | 175 + pkg/images/tv/iis/lumatch.cl | 8 + pkg/images/tv/iis/lumatch.par | 2 + pkg/images/tv/iis/mkpkg | 25 + pkg/images/tv/iis/monochrome.cl | 5 + pkg/images/tv/iis/pseudocolor.cl | 24 + pkg/images/tv/iis/pseudocolor.par | 7 + pkg/images/tv/iis/rgb.cl | 11 + pkg/images/tv/iis/rgb.par | 4 + pkg/images/tv/iis/src/blink.x | 132 + pkg/images/tv/iis/src/clear.x | 48 + pkg/images/tv/iis/src/cv.com | 16 + pkg/images/tv/iis/src/cv.h | 51 + pkg/images/tv/iis/src/cv.x | 175 + pkg/images/tv/iis/src/cvparse.x | 196 + pkg/images/tv/iis/src/cvulut.x | 130 + pkg/images/tv/iis/src/cvutil.x | 538 + pkg/images/tv/iis/src/display.x | 104 + pkg/images/tv/iis/src/gwindow.h | 34 + pkg/images/tv/iis/src/load1.x | 324 + pkg/images/tv/iis/src/load2.x | 335 + pkg/images/tv/iis/src/map.x | 320 + pkg/images/tv/iis/src/match.x | 172 + pkg/images/tv/iis/src/maxmin.x | 52 + pkg/images/tv/iis/src/mkpkg | 39 + pkg/images/tv/iis/src/offset.x | 53 + pkg/images/tv/iis/src/pan.x | 99 + pkg/images/tv/iis/src/range.x | 57 + pkg/images/tv/iis/src/rdcur.x | 111 + pkg/images/tv/iis/src/reset.x | 37 + pkg/images/tv/iis/src/sigl2.x | 677 + pkg/images/tv/iis/src/snap.x | 64 + pkg/images/tv/iis/src/split.x | 95 + pkg/images/tv/iis/src/tell.x | 24 + pkg/images/tv/iis/src/text.x | 71 + pkg/images/tv/iis/src/window.x | 181 + pkg/images/tv/iis/src/zoom.x | 60 + pkg/images/tv/iis/src/zscale.x | 457 + pkg/images/tv/iis/window.cl | 5 + pkg/images/tv/iis/x_iis.x | 7 + pkg/images/tv/iis/zoom.cl | 11 + pkg/images/tv/iis/zoom.par | 2 + pkg/images/tv/imedit.par | 24 + pkg/images/tv/imedit/bpmedit.cl | 69 + pkg/images/tv/imedit/bpmedit.key | 51 + pkg/images/tv/imedit/epbackground.x | 71 + pkg/images/tv/imedit/epcol.x | 80 + pkg/images/tv/imedit/epcolon.x | 335 + pkg/images/tv/imedit/epconstant.x | 51 + pkg/images/tv/imedit/epdisplay.x | 196 + pkg/images/tv/imedit/epdosurface.x | 35 + pkg/images/tv/imedit/epgcur.x | 127 + pkg/images/tv/imedit/epgdata.x | 70 + pkg/images/tv/imedit/epgsfit.x | 74 + pkg/images/tv/imedit/epimcopy.x | 72 + pkg/images/tv/imedit/epinput.x | 55 + pkg/images/tv/imedit/epix.h | 50 + pkg/images/tv/imedit/epline.x | 80 + pkg/images/tv/imedit/epmask.x | 177 + pkg/images/tv/imedit/epmove.x | 129 + pkg/images/tv/imedit/epnoise.x | 95 + pkg/images/tv/imedit/epreplace.gx | 167 + pkg/images/tv/imedit/epreplace.x | 260 + pkg/images/tv/imedit/epsearch.x | 90 + pkg/images/tv/imedit/epsetpars.x | 75 + pkg/images/tv/imedit/epstatistics.x | 147 + pkg/images/tv/imedit/epsurface.x | 46 + pkg/images/tv/imedit/imedit.key | 84 + pkg/images/tv/imedit/mkpkg | 38 + pkg/images/tv/imedit/t_imedit.x | 305 + pkg/images/tv/imexamine.par | 22 + pkg/images/tv/imexamine/iecimexam.x | 81 + pkg/images/tv/imexamine/iecolon.x | 1038 ++ pkg/images/tv/imexamine/iedisplay.x | 55 + pkg/images/tv/imexamine/ieeimexam.x | 243 + pkg/images/tv/imexamine/iegcur.x | 242 + pkg/images/tv/imexamine/iegdata.x | 45 + pkg/images/tv/imexamine/iegimage.x | 261 + pkg/images/tv/imexamine/iegnfr.x | 61 + pkg/images/tv/imexamine/iegraph.x | 145 + pkg/images/tv/imexamine/iehimexam.x | 193 + pkg/images/tv/imexamine/ieimname.x | 33 + pkg/images/tv/imexamine/iejimexam.x | 473 + pkg/images/tv/imexamine/ielimexam.x | 81 + pkg/images/tv/imexamine/iemw.x | 191 + pkg/images/tv/imexamine/ieopenlog.x | 39 + pkg/images/tv/imexamine/iepos.x | 180 + pkg/images/tv/imexamine/ieprint.x | 67 + pkg/images/tv/imexamine/ieqrimexam.x | 489 + pkg/images/tv/imexamine/ierimexam.x | 752 ++ pkg/images/tv/imexamine/iesimexam.x | 492 + pkg/images/tv/imexamine/iestatistics.x | 84 + pkg/images/tv/imexamine/ietimexam.x | 121 + pkg/images/tv/imexamine/ievimexam.x | 582 + pkg/images/tv/imexamine/imexam.h | 55 + pkg/images/tv/imexamine/imexamine.par | 22 + pkg/images/tv/imexamine/mkpkg | 48 + pkg/images/tv/imexamine/starfocus.h | 140 + pkg/images/tv/imexamine/stfmeasure.x | 147 + pkg/images/tv/imexamine/stfprofile.x | 1189 ++ pkg/images/tv/imexamine/t_imexam.x | 352 + pkg/images/tv/imexamine/x_imexam.x | 1 + pkg/images/tv/jimexam.par | 29 + pkg/images/tv/kimexam.par | 29 + pkg/images/tv/limexam.par | 22 + pkg/images/tv/mkpkg | 37 + pkg/images/tv/rimexam.par | 35 + pkg/images/tv/simexam.par | 10 + pkg/images/tv/tv.cl | 43 + pkg/images/tv/tv.hd | 23 + pkg/images/tv/tv.men | 7 + pkg/images/tv/tv.par | 1 + pkg/images/tv/tvmark.par | 23 + pkg/images/tv/tvmark/asciilook.inc | 19 + pkg/images/tv/tvmark/mkbmark.x | 561 + pkg/images/tv/tvmark/mkcolon.x | 394 + pkg/images/tv/tvmark/mkfind.x | 52 + pkg/images/tv/tvmark/mkgmarks.x | 214 + pkg/images/tv/tvmark/mkgpars.x | 65 + pkg/images/tv/tvmark/mkgscur.x | 87 + pkg/images/tv/tvmark/mkmag.x | 20 + pkg/images/tv/tvmark/mkmark.x | 482 + pkg/images/tv/tvmark/mknew.x | 42 + pkg/images/tv/tvmark/mkonemark.x | 392 + pkg/images/tv/tvmark/mkoutname.x | 273 + pkg/images/tv/tvmark/mkpkg | 27 + pkg/images/tv/tvmark/mkppars.x | 40 + pkg/images/tv/tvmark/mkremove.x | 98 + pkg/images/tv/tvmark/mkshow.x | 95 + pkg/images/tv/tvmark/mktext.x | 164 + pkg/images/tv/tvmark/mktools.x | 505 + pkg/images/tv/tvmark/pixelfont.inc | 519 + pkg/images/tv/tvmark/t_tvmark.x | 267 + pkg/images/tv/tvmark/tvmark.h | 165 + pkg/images/tv/vimexam.par | 24 + pkg/images/tv/wcslab.par | 15 + pkg/images/tv/wcslab/mkpkg | 24 + pkg/images/tv/wcslab/t_wcslab.x | 137 + pkg/images/tv/wcslab/wcs_desc.h | 219 + pkg/images/tv/wcslab/wcslab.h | 98 + pkg/images/tv/wcslab/wcslab.x | 940 ++ pkg/images/tv/wcslab/wlgrid.x | 448 + pkg/images/tv/wcslab/wllabel.x | 1077 ++ pkg/images/tv/wcslab/wlsetup.x | 1000 ++ pkg/images/tv/wcslab/wlutil.x | 390 + pkg/images/tv/wcslab/wlwcslab.x | 181 + pkg/images/tv/wcslab/zz.x | 23 + pkg/images/tv/wcspars.par | 19 + pkg/images/tv/wlpars.par | 45 + pkg/images/tv/x_tv.x | 10 + pkg/images/x_images.x | 80 + pkg/language/doc/access.hlp | 48 + pkg/language/doc/back.hlp | 28 + pkg/language/doc/beep.hlp | 19 + pkg/language/doc/break.hlp | 49 + pkg/language/doc/bye.hlp | 26 + pkg/language/doc/cache.hlp | 48 + pkg/language/doc/chdir.hlp | 62 + pkg/language/doc/cl.hlp | 126 + pkg/language/doc/clear.hlp | 22 + pkg/language/doc/commands.hlp | 200 + pkg/language/doc/cursors.hlp | 671 + pkg/language/doc/decls.hlp | 144 + pkg/language/doc/defpac.hlp | 83 + pkg/language/doc/dparam.hlp | 70 + pkg/language/doc/edit.hlp | 55 + pkg/language/doc/ehistory.hlp | 67 + pkg/language/doc/envget.hlp | 30 + pkg/language/doc/eparam.hlp | 138 + pkg/language/doc/error.hlp | 40 + pkg/language/doc/flprcache.hlp | 62 + pkg/language/doc/for.hlp | 56 + pkg/language/doc/fprint.hlp | 154 + pkg/language/doc/gflush.hlp | 32 + pkg/language/doc/goto.hlp | 57 + pkg/language/doc/hidetask.hlp | 50 + pkg/language/doc/history.hlp | 42 + pkg/language/doc/if.hlp | 65 + pkg/language/doc/imaccess.hlp | 40 + pkg/language/doc/intro.hlp | 100 + pkg/language/doc/isindef.hlp | 56 + pkg/language/doc/jobs.hlp | 50 + pkg/language/doc/keep.hlp | 32 + pkg/language/doc/kill.hlp | 28 + pkg/language/doc/logging.hlp | 82 + pkg/language/doc/logout.hlp | 28 + pkg/language/doc/lparam.hlp | 64 + pkg/language/doc/mathfcns.hlp | 56 + pkg/language/doc/mktemp.hlp | 32 + pkg/language/doc/next.hlp | 29 + pkg/language/doc/osfn.hlp | 34 + pkg/language/doc/package.hlp | 75 + pkg/language/doc/params.hlp | 288 + pkg/language/doc/prcache.hlp | 94 + pkg/language/doc/proc.hlp | 92 + pkg/language/doc/putlog.hlp | 24 + pkg/language/doc/radix.hlp | 45 + pkg/language/doc/return.hlp | 31 + pkg/language/doc/scan.hlp | 144 + pkg/language/doc/service.hlp | 43 + pkg/language/doc/set.hlp | 82 + pkg/language/doc/show.hlp | 31 + pkg/language/doc/sleep.hlp | 25 + pkg/language/doc/strings.hlp | 78 + pkg/language/doc/stty.hlp | 589 + pkg/language/doc/switch.hlp | 82 + pkg/language/doc/task.hlp | 161 + pkg/language/doc/time.hlp | 19 + pkg/language/doc/unlearn.hlp | 61 + pkg/language/doc/update.hlp | 34 + pkg/language/doc/wait.hlp | 36 + pkg/language/doc/which.hlp | 45 + pkg/language/doc/while.hlp | 44 + pkg/language/language.hd | 84 + pkg/language/language.men | 89 + pkg/language/language.par | 1 + pkg/lists/README | 1 + pkg/lists/Revisions | 52 + pkg/lists/average.cl | 56 + pkg/lists/average.par | 10 + pkg/lists/columns.par | 4 + pkg/lists/columns.x | 65 + pkg/lists/doc/Lcalc.hlp | 539 + pkg/lists/doc/Lintran.spc.hlp | 60 + pkg/lists/doc/Lists.hlp | 569 + pkg/lists/doc/average.hlp | 49 + pkg/lists/doc/columns.hlp | 38 + pkg/lists/doc/lintran.hlp | 103 + pkg/lists/doc/raverage.hlp | 110 + pkg/lists/doc/rgcursor.hlp | 94 + pkg/lists/doc/rimcursor.hlp | 270 + pkg/lists/doc/table.hlp | 43 + pkg/lists/doc/tokens.hlp | 55 + pkg/lists/doc/unique.hlp | 27 + pkg/lists/doc/words.hlp | 22 + pkg/lists/filter.cl | 6 + pkg/lists/lintran.par | 12 + pkg/lists/lintran.x | 370 + pkg/lists/lists.cl | 20 + pkg/lists/lists.hd | 14 + pkg/lists/lists.men | 10 + pkg/lists/lists.par | 4 + pkg/lists/mkpkg | 32 + pkg/lists/raverage.cl | 146 + pkg/lists/rgcursor.x | 27 + pkg/lists/rimcursor.par | 5 + pkg/lists/rimcursor.x | 191 + pkg/lists/table.par | 5 + pkg/lists/table.x | 111 + pkg/lists/tokens.par | 5 + pkg/lists/tokens.x | 140 + pkg/lists/unique.par | 1 + pkg/lists/unique.x | 46 + pkg/lists/words.par | 1 + pkg/lists/words.x | 44 + pkg/lists/x_lists.x | 12 + pkg/mkpkg | 83 + pkg/obsolete/Revisions | 120 + pkg/obsolete/doc/imtitle.hlp | 26 + pkg/obsolete/doc/mkhistogram.hlp | 61 + pkg/obsolete/doc/ofixpix.hlp | 85 + pkg/obsolete/doc/oimcombine.hlp | 1013 ++ pkg/obsolete/doc/oimstat.hlp | 108 + pkg/obsolete/doc/orfits.hlp | 164 + pkg/obsolete/doc/owfits.hlp | 205 + pkg/obsolete/doc/radplt.hlp | 57 + pkg/obsolete/fits/README | 1 + pkg/obsolete/fits/fits_cards.x | 250 + pkg/obsolete/fits/fits_params.x | 234 + pkg/obsolete/fits/fits_read.x | 173 + pkg/obsolete/fits/fits_rheader.x | 575 + pkg/obsolete/fits/fits_rimage.x | 605 + pkg/obsolete/fits/fits_rpixels.x | 154 + pkg/obsolete/fits/fits_wheader.x | 471 + pkg/obsolete/fits/fits_wimage.x | 416 + pkg/obsolete/fits/fits_wpixels.x | 162 + pkg/obsolete/fits/fits_write.x | 156 + pkg/obsolete/fits/mkpkg | 23 + pkg/obsolete/fits/ranges.x | 234 + pkg/obsolete/fits/rfits.com | 18 + pkg/obsolete/fits/rfits.h | 80 + pkg/obsolete/fits/structure.hlp | 363 + pkg/obsolete/fits/t_rfits.x | 184 + pkg/obsolete/fits/t_wfits.x | 216 + pkg/obsolete/fits/wfits.com | 15 + pkg/obsolete/fits/wfits.h | 113 + pkg/obsolete/fixcol.gx | 45 + pkg/obsolete/fixcol.x | 248 + pkg/obsolete/fixline.gx | 50 + pkg/obsolete/fixline.x | 242 + pkg/obsolete/generic/fixcol.x | 250 + pkg/obsolete/generic/fixline.x | 244 + pkg/obsolete/generic/mkpkg | 11 + pkg/obsolete/imcombine/generic/icaclip.x | 2198 ++++ pkg/obsolete/imcombine/generic/icaverage.x | 337 + pkg/obsolete/imcombine/generic/iccclip.x | 1790 +++ pkg/obsolete/imcombine/generic/icgdata.x | 918 ++ pkg/obsolete/imcombine/generic/icgrow.x | 251 + pkg/obsolete/imcombine/generic/icmedian.x | 556 + pkg/obsolete/imcombine/generic/icmm.x | 612 + pkg/obsolete/imcombine/generic/icombine.x | 1645 +++ pkg/obsolete/imcombine/generic/icpclip.x | 878 ++ pkg/obsolete/imcombine/generic/icsclip.x | 1922 +++ pkg/obsolete/imcombine/generic/icsigma.x | 405 + pkg/obsolete/imcombine/generic/icsort.x | 1096 ++ pkg/obsolete/imcombine/generic/icstat.x | 880 ++ pkg/obsolete/imcombine/generic/mkpkg | 23 + pkg/obsolete/imcombine/icaclip.gx | 573 + pkg/obsolete/imcombine/icaverage.gx | 97 + pkg/obsolete/imcombine/iccclip.gx | 471 + pkg/obsolete/imcombine/icgdata.gx | 235 + pkg/obsolete/imcombine/icgrow.gx | 123 + pkg/obsolete/imcombine/icimstack.x | 129 + pkg/obsolete/imcombine/iclog.x | 384 + pkg/obsolete/imcombine/icmask.com | 8 + pkg/obsolete/imcombine/icmask.x | 314 + pkg/obsolete/imcombine/icmedian.gx | 180 + pkg/obsolete/imcombine/icmm.gx | 181 + pkg/obsolete/imcombine/icombine.com | 38 + pkg/obsolete/imcombine/icombine.gx | 580 + pkg/obsolete/imcombine/icombine.h | 52 + pkg/obsolete/imcombine/icpclip.gx | 233 + pkg/obsolete/imcombine/icrmasks.x | 41 + pkg/obsolete/imcombine/icscale.x | 358 + pkg/obsolete/imcombine/icsclip.gx | 504 + pkg/obsolete/imcombine/icsection.x | 94 + pkg/obsolete/imcombine/icsetout.x | 273 + pkg/obsolete/imcombine/icsigma.gx | 115 + pkg/obsolete/imcombine/icsort.gx | 386 + pkg/obsolete/imcombine/icstat.gx | 237 + pkg/obsolete/imcombine/mkpkg | 54 + pkg/obsolete/imcombine/t_imcombine.x | 501 + pkg/obsolete/imtitle.par | 4 + pkg/obsolete/mkhistogram.par | 7 + pkg/obsolete/mkpkg | 41 + pkg/obsolete/obsolete.cl | 14 + pkg/obsolete/obsolete.hd | 15 + pkg/obsolete/obsolete.men | 11 + pkg/obsolete/obsolete.par | 3 + pkg/obsolete/ofixpix.par | 5 + pkg/obsolete/oimcombine.par | 38 + pkg/obsolete/oimstat.h | 50 + pkg/obsolete/oimstatistics.par | 6 + pkg/obsolete/orfits.par | 13 + pkg/obsolete/owfits.par | 14 + pkg/obsolete/radplt.par | 5 + pkg/obsolete/t_fixpix.x | 172 + pkg/obsolete/t_imtitle.x | 21 + pkg/obsolete/t_mkhgm.x | 137 + pkg/obsolete/t_oimstat.x | 1014 ++ pkg/obsolete/t_radplt.x | 305 + pkg/obsolete/x_obsolete.x | 8 + pkg/plot/README | 3 + pkg/plot/Revisions | 726 ++ pkg/plot/calcomp.par | 17 + pkg/plot/contour.par | 22 + pkg/plot/crtpict.par | 20 + pkg/plot/crtpict/calchgms.x | 192 + pkg/plot/crtpict/crtpict.h | 43 + pkg/plot/crtpict/crtpict.semi | 263 + pkg/plot/crtpict/crtulut.x | 130 + pkg/plot/crtpict/drawgraph.x | 153 + pkg/plot/crtpict/drawgrey.x | 63 + pkg/plot/crtpict/mapimage.x | 172 + pkg/plot/crtpict/minmax.x | 75 + pkg/plot/crtpict/mkpkg | 24 + pkg/plot/crtpict/plothgms.x | 209 + pkg/plot/crtpict/plotimage.x | 40 + pkg/plot/crtpict/setxform.x | 96 + pkg/plot/crtpict/sigl2.x | 677 + pkg/plot/crtpict/t_crtpict.x | 162 + pkg/plot/crtpict/tweakndc.x | 66 + pkg/plot/crtpict/wdes.h | 33 + pkg/plot/crtpict/xformimage.x | 117 + pkg/plot/crtpict/xyscale.x | 90 + pkg/plot/crtpict/zscale.x | 441 + pkg/plot/doc/calcomp.hlp | 173 + pkg/plot/doc/contour.hlp | 166 + pkg/plot/doc/crtpict.hlp | 171 + pkg/plot/doc/gdevices.hlp | 75 + pkg/plot/doc/gkidecode.hlp | 51 + pkg/plot/doc/gkidir.hlp | 42 + pkg/plot/doc/gkiextract.hlp | 45 + pkg/plot/doc/gkimosaic.hlp | 110 + pkg/plot/doc/graph.hlp | 247 + pkg/plot/doc/hafton.hlp | 123 + pkg/plot/doc/imdkern.hlp | 105 + pkg/plot/doc/implot.hlp | 231 + pkg/plot/doc/nsppkern.hlp | 56 + pkg/plot/doc/pcol.hlp | 147 + pkg/plot/doc/pcols.hlp | 150 + pkg/plot/doc/phistogram.hlp | 181 + pkg/plot/doc/pradprof.hlp | 132 + pkg/plot/doc/prow.hlp | 146 + pkg/plot/doc/prows.hlp | 151 + pkg/plot/doc/pvector.hlp | 191 + pkg/plot/doc/sgidecode.hlp | 40 + pkg/plot/doc/sgikern.hlp | 178 + pkg/plot/doc/showcap.hlp | 99 + pkg/plot/doc/stdgraph.hlp | 72 + pkg/plot/doc/stdplot.hlp | 56 + pkg/plot/doc/surface.hlp | 95 + pkg/plot/doc/velvect.hlp | 47 + pkg/plot/gdevices.par | 2 + pkg/plot/gdevices.x | 116 + pkg/plot/getdata.x | 212 + pkg/plot/gkidecode.par | 4 + pkg/plot/gkidir.par | 1 + pkg/plot/gkiextract.par | 5 + pkg/plot/gkimosaic.par | 9 + pkg/plot/graph.par | 40 + pkg/plot/hafton.par | 19 + pkg/plot/hgpline.x | 56 + pkg/plot/imdkern.par | 8 + pkg/plot/implot.par | 6 + pkg/plot/impprofile.x | 221 + pkg/plot/improject.x | 73 + pkg/plot/impstatus.x | 48 + pkg/plot/initmarker.x | 47 + pkg/plot/mkpkg | 80 + pkg/plot/nsppkern.par | 6 + pkg/plot/pcol.par | 28 + pkg/plot/pcols.par | 29 + pkg/plot/perim.x | 176 + pkg/plot/phistogram.par | 37 + pkg/plot/phistogram.x | 573 + pkg/plot/phminmax.x | 74 + pkg/plot/plot.cl | 41 + pkg/plot/plot.hd | 33 + pkg/plot/plot.men | 27 + pkg/plot/plot.par | 1 + pkg/plot/pltwcs.x | 258 + pkg/plot/pradprof.par | 35 + pkg/plot/prow.par | 28 + pkg/plot/prows.par | 29 + pkg/plot/pvector.par | 39 + pkg/plot/sgidecode.par | 4 + pkg/plot/sgikern.par | 6 + pkg/plot/stdgraph.par | 9 + pkg/plot/stdplot.par | 6 + pkg/plot/surface.par | 13 + pkg/plot/t_contour.x | 255 + pkg/plot/t_gkidir.x | 128 + pkg/plot/t_gkimos.x | 1067 ++ pkg/plot/t_gkixt.x | 325 + pkg/plot/t_graph.x | 731 ++ pkg/plot/t_hafton.x | 305 + pkg/plot/t_implot.x | 1202 ++ pkg/plot/t_pcol.x | 58 + pkg/plot/t_pcols.x | 243 + pkg/plot/t_pradprof.x | 548 + pkg/plot/t_prow.x | 58 + pkg/plot/t_prows.x | 243 + pkg/plot/t_pvector.x | 979 ++ pkg/plot/t_surface.x | 501 + pkg/plot/t_velvect.x | 124 + pkg/plot/velvect.par | 6 + pkg/plot/vport.x | 94 + pkg/plot/x_ncar.x | 8 + pkg/plot/x_plot.x | 18 + pkg/proto/README | 12 + pkg/proto/Revisions | 926 ++ pkg/proto/binfil.par | 3 + pkg/proto/bscale.par | 9 + pkg/proto/color/README | 87 + pkg/proto/color/Revisions | 81 + pkg/proto/color/color.cl | 10 + pkg/proto/color/color.hd | 13 + pkg/proto/color/color.men | 8 + pkg/proto/color/color.par | 3 + pkg/proto/color/color.readme | 139 + pkg/proto/color/doc/color.hlp | 215 + pkg/proto/color/doc/rgbdisplay.hlp | 113 + pkg/proto/color/doc/rgbdither.hlp | 91 + pkg/proto/color/doc/rgbsun.hlp | 92 + pkg/proto/color/doc/rgbto8.hlp | 93 + pkg/proto/color/lib/helpdb.mip | Bin 0 -> 3118 bytes pkg/proto/color/lib/imtoolrgb.lut | 256 + pkg/proto/color/lib/mkpkg.inc | 11 + pkg/proto/color/lib/mkpkg.sf.SUN3 | 1 + pkg/proto/color/lib/root.hd | 3 + pkg/proto/color/lib/rootcolor.hd | 7 + pkg/proto/color/lib/saorgb.lut | 9 + pkg/proto/color/lib/strip.color | 9 + pkg/proto/color/lib/zzsetenv.def | 7 + pkg/proto/color/mkpkg | 20 + pkg/proto/color/src/mkpkg | 29 + pkg/proto/color/src/rgbdisplay.cl | 1 + pkg/proto/color/src/rgbdisplay.par | 2 + pkg/proto/color/src/rgbdither.par | 13 + pkg/proto/color/src/rgbsun.par | 12 + pkg/proto/color/src/rgbto8.par | 13 + pkg/proto/color/src/t_rgbdither.x | 198 + pkg/proto/color/src/t_rgbsun.x | 135 + pkg/proto/color/src/t_rgbto8.x | 1088 ++ pkg/proto/color/src/x_color.x | 3 + pkg/proto/doc/binfil.hlp | 71 + pkg/proto/doc/bscale.hlp | 151 + pkg/proto/doc/epix.hlp | 55 + pkg/proto/doc/fields.hlp | 65 + pkg/proto/doc/fixpix.hlp | 190 + pkg/proto/doc/hfix.hlp | 79 + pkg/proto/doc/imalign.hlp | 328 + pkg/proto/doc/imcentroid.hlp | 247 + pkg/proto/doc/imcntr.hlp | 61 + pkg/proto/doc/imextensions.hlp | 235 + pkg/proto/doc/imfunction.hlp | 130 + pkg/proto/doc/imreplace.hlp | 62 + pkg/proto/doc/imscale.hlp | 43 + pkg/proto/doc/interp.hlp | 84 + pkg/proto/doc/irafil.hlp | 106 + pkg/proto/doc/joinlines.hlp | 127 + pkg/proto/doc/mimstat.hlp | 179 + pkg/proto/doc/mkglbhdr.hlp | 114 + pkg/proto/doc/mskexpr.hlp | 454 + pkg/proto/doc/mskregions.hlp | 279 + pkg/proto/doc/ringavg.hlp | 83 + pkg/proto/doc/rskysub.hlp | 234 + pkg/proto/doc/suntoiraf.hlp | 226 + pkg/proto/doc/text2mask.hlp | 90 + pkg/proto/doc/wcsedit.hlp | 422 + pkg/proto/doc/wcsreset.hlp | 272 + pkg/proto/epix.par | 8 + pkg/proto/epix.x | 110 + pkg/proto/fields.par | 5 + pkg/proto/fields.x | 316 + pkg/proto/fixpix.par | 6 + pkg/proto/hfix.par | 3 + pkg/proto/imcntr.par | 4 + pkg/proto/imextensions.par | 12 + pkg/proto/imscale.par | 8 + pkg/proto/interp.par | 7 + pkg/proto/interp.x | 132 + pkg/proto/intrp.f | 313 + pkg/proto/irafil.par | 9 + pkg/proto/joinlines.par | 9 + pkg/proto/maskexpr/gettok.h | 22 + pkg/proto/maskexpr/gettok.x | 922 ++ pkg/proto/maskexpr/megeom.x | 72 + pkg/proto/maskexpr/megsym.x | 31 + pkg/proto/maskexpr/memkmask.x | 839 ++ pkg/proto/maskexpr/meregfuncs.x | 1449 +++ pkg/proto/maskexpr/meregmask.x | 753 ++ pkg/proto/maskexpr/mesetexpr.x | 36 + pkg/proto/maskexpr/mesetreg.x | 292 + pkg/proto/maskexpr/mkpkg | 26 + pkg/proto/maskexpr/mskexpand.x | 261 + pkg/proto/maskexpr/peregfuncs.h | 131 + pkg/proto/maskexpr/peregfuncs.x | 877 ++ pkg/proto/maskexpr/peregufcn.x | 808 ++ pkg/proto/maskexpr/t_mskexpr.x | 286 + pkg/proto/maskexpr/t_mskregions.x | 264 + pkg/proto/masks/mimstat.h | 67 + pkg/proto/masks/mimstat.x | 943 ++ pkg/proto/masks/mkpkg | 23 + pkg/proto/masks/mptools.x | 468 + pkg/proto/masks/mstcache.x | 100 + pkg/proto/masks/rsfnames.x | 549 + pkg/proto/masks/rskysub.h | 32 + pkg/proto/masks/rsmean.x | 1172 ++ pkg/proto/masks/rsmmean.x | 1673 +++ pkg/proto/masks/rsreject.x | 1220 ++ pkg/proto/masks/rsscache.x | 123 + pkg/proto/masks/rsstats.x | 492 + pkg/proto/masks/t_mimstat.x | 363 + pkg/proto/masks/t_mimstat.xBAK | 366 + pkg/proto/masks/t_rskysub.x | 248 + pkg/proto/mimstatistics.par | 13 + pkg/proto/mkglbhdr.par | 4 + pkg/proto/mkpkg | 47 + pkg/proto/mskexpr.par | 10 + pkg/proto/mskregions.par | 12 + pkg/proto/proto.cl | 38 + pkg/proto/proto.hd | 46 + pkg/proto/proto.men | 24 + pkg/proto/proto.par | 3 + pkg/proto/ringavg.cl | 172 + pkg/proto/rskysub.par | 33 + pkg/proto/suntoiraf.par | 6 + pkg/proto/t_binfil.x | 257 + pkg/proto/t_bscale.x | 581 + pkg/proto/t_fixpix.x | 154 + pkg/proto/t_hfix.x | 140 + pkg/proto/t_imcntr.x | 198 + pkg/proto/t_imext.x | 93 + pkg/proto/t_imscale.x | 151 + pkg/proto/t_joinlines.x | 139 + pkg/proto/t_mask2text.x | 118 + pkg/proto/t_mkglbhdr.x | 167 + pkg/proto/t_suntoiraf.x | 268 + pkg/proto/t_text2mask.x | 102 + pkg/proto/text2mask.par | 8 + pkg/proto/vol/README | 26 + pkg/proto/vol/README.install | 107 + pkg/proto/vol/Revisions | 12 + pkg/proto/vol/lib/helpdb.mip | Bin 0 -> 2966 bytes pkg/proto/vol/lib/mkpkg.inc | 7 + pkg/proto/vol/lib/root.hd | 5 + pkg/proto/vol/lib/rootvol.hd | 8 + pkg/proto/vol/lib/strip.vol | 12 + pkg/proto/vol/lib/zzsetenv.def | 7 + pkg/proto/vol/mkpkg | 21 + pkg/proto/vol/src/doc/concept.hlp | 177 + pkg/proto/vol/src/doc/i2sun.hlp | 152 + pkg/proto/vol/src/doc/im3dtran.hlp | 85 + pkg/proto/vol/src/doc/imjoin.hlp | 76 + pkg/proto/vol/src/doc/proj.hlp | 139 + pkg/proto/vol/src/doc/pvol.hlp | 398 + pkg/proto/vol/src/doc/volumes.hlp | 56 + pkg/proto/vol/src/i2sun.par | 14 + pkg/proto/vol/src/i2sun/cnvimage.x | 142 + pkg/proto/vol/src/i2sun/i2sun.h | 46 + pkg/proto/vol/src/i2sun/mkpkg | 27 + pkg/proto/vol/src/i2sun/sigln.x | 783 ++ pkg/proto/vol/src/i2sun/t_i2sun.x | 240 + pkg/proto/vol/src/i2sun/trsetup.x | 32 + pkg/proto/vol/src/i2sun/trulut.x | 128 + pkg/proto/vol/src/i2sun/x_i2sun.x | 4 + pkg/proto/vol/src/im3dtran.par | 6 + pkg/proto/vol/src/im3dtran/mkpkg | 52 + pkg/proto/vol/src/im3dtran/t_im3dtran.x | 307 + pkg/proto/vol/src/im3dtran/txyz3.gx | 18 + pkg/proto/vol/src/im3dtran/txyz3.x | 103 + pkg/proto/vol/src/im3dtran/txzy3.gx | 18 + pkg/proto/vol/src/im3dtran/txzy3.x | 103 + pkg/proto/vol/src/im3dtran/tyxz3.gx | 18 + pkg/proto/vol/src/im3dtran/tyxz3.x | 103 + pkg/proto/vol/src/im3dtran/tyzx3.gx | 18 + pkg/proto/vol/src/im3dtran/tyzx3.x | 103 + pkg/proto/vol/src/im3dtran/tzxy3.gx | 18 + pkg/proto/vol/src/im3dtran/tzxy3.x | 103 + pkg/proto/vol/src/im3dtran/tzyx3.gx | 18 + pkg/proto/vol/src/im3dtran/tzyx3.x | 103 + pkg/proto/vol/src/im3dtran/x_im3dtran.x | 4 + pkg/proto/vol/src/imjoin.gx | 86 + pkg/proto/vol/src/imjoin.par | 4 + pkg/proto/vol/src/imjoin.x | 471 + pkg/proto/vol/src/imminmax.x | 73 + pkg/proto/vol/src/mkpkg | 44 + pkg/proto/vol/src/pv_gmem.x | 109 + pkg/proto/vol/src/pvol.h | 58 + pkg/proto/vol/src/pvol.par | 25 + pkg/proto/vol/src/t_imjoin.x | 190 + pkg/proto/vol/src/t_pvol.x | 284 + pkg/proto/vol/src/vgetincr.x | 92 + pkg/proto/vol/src/vmatrix.x | 31 + pkg/proto/vol/src/vproject.x | 224 + pkg/proto/vol/src/vtransmit.gx | 146 + pkg/proto/vol/src/vtransmit.x | 856 ++ pkg/proto/vol/src/x_vol.x | 6 + pkg/proto/vol/vol.cl | 22 + pkg/proto/vol/vol.hd | 10 + pkg/proto/vol/vol.men | 4 + pkg/proto/vol/vol.par | 3 + pkg/proto/x_proto.x | 22 + pkg/softools/README | 3 + pkg/softools/memchk.par | 2 + pkg/softools/memchk.x | 102 + pkg/softools/mkmanpage.cl | 15 + pkg/softools/mkmanpage.hlp | 43 + pkg/softools/mkmanpage.par | 5 + pkg/softools/mkpkg | 24 + pkg/softools/mktags.hlp | 54 + pkg/softools/mktags.par | 3 + pkg/softools/mktags.x | 172 + pkg/softools/mkttydata.hlp | 110 + pkg/softools/mkttydata.par | 4 + pkg/softools/softools.cl | 26 + pkg/softools/softools.hd | 19 + pkg/softools/softools.men | 15 + pkg/softools/softools.par | 4 + pkg/softools/tgutil.x | 136 + pkg/softools/x_softools.x | 6 + pkg/system/README | 5 + pkg/system/bench.cl | 143 + pkg/system/chkupdate.par | 5 + pkg/system/chkupdate.x | 178 + pkg/system/cmdstr.par | 2 + pkg/system/cmdstr.x | 157 + pkg/system/concatenate.par | 4 + pkg/system/concatenate.x | 73 + pkg/system/copy.par | 3 + pkg/system/copy.x | 62 + pkg/system/count.par | 1 + pkg/system/count.x | 131 + pkg/system/delete.par | 6 + pkg/system/delete.x | 74 + pkg/system/devices.cl | 3 + pkg/system/directory.par | 6 + pkg/system/directory.x | 561 + pkg/system/doc/Sys.hlp | 349 + pkg/system/doc/Sys_intro.hlp | 137 + pkg/system/doc/allocate.hlp | 52 + pkg/system/doc/bench.hlp | 56 + pkg/system/doc/chkupdate.hlp | 72 + pkg/system/doc/concatenate.hlp | 82 + pkg/system/doc/copy.hlp | 47 + pkg/system/doc/count.hlp | 44 + pkg/system/doc/deallocate.hlp | 34 + pkg/system/doc/delete.hlp | 57 + pkg/system/doc/devstatus.hlp | 57 + pkg/system/doc/directory.hlp | 148 + pkg/system/doc/diskspace.hlp | 33 + pkg/system/doc/fcache.hlp | 140 + pkg/system/doc/files.hlp | 72 + pkg/system/doc/gripes.hlp | 67 + pkg/system/doc/head.hlp | 39 + pkg/system/doc/help.hlp | 599 + pkg/system/doc/lprint.hlp | 65 + pkg/system/doc/match.hlp | 77 + pkg/system/doc/mkdir.hlp | 34 + pkg/system/doc/mkscript.hlp | 161 + pkg/system/doc/movefiles.hlp | 38 + pkg/system/doc/netstatus.hlp | 44 + pkg/system/doc/news.hlp | 58 + pkg/system/doc/page.hlp | 146 + pkg/system/doc/pathnames.hlp | 42 + pkg/system/doc/phelp.hlp | 61 + pkg/system/doc/protect.hlp | 36 + pkg/system/doc/references.hlp | 78 + pkg/system/doc/rename.hlp | 69 + pkg/system/doc/rewind.hlp | 36 + pkg/system/doc/sort.hlp | 62 + pkg/system/doc/spy.hlp | 26 + pkg/system/doc/tail.hlp | 50 + pkg/system/doc/tee.hlp | 36 + pkg/system/doc/touch.hlp | 71 + pkg/system/doc/type.hlp | 43 + pkg/system/doc/unprotect.hlp | 27 + pkg/system/doc/urlget.hlp | 84 + pkg/system/fcache.par | 9 + pkg/system/files.par | 2 + pkg/system/files.x | 32 + pkg/system/hdbexamine.par | 2 + pkg/system/head.par | 2 + pkg/system/head.x | 56 + pkg/system/help.par | 31 + pkg/system/help/README | 12 + pkg/system/help/design.hlp | 500 + pkg/system/help/filetemp.x | 28 + pkg/system/help/getoption.x | 52 + pkg/system/help/hbgetblk.x | 195 + pkg/system/help/hdbexamine.hlp | 55 + pkg/system/help/help.h | 115 + pkg/system/help/helpdb.x | 1203 ++ pkg/system/help/helpdir.h | 34 + pkg/system/help/helpdir.x | 775 ++ pkg/system/help/hinput.x | 274 + pkg/system/help/houtput.x | 147 + pkg/system/help/lroff/breakline.o | Bin 0 -> 2788 bytes pkg/system/help/lroff/breakline.x | 99 + pkg/system/help/lroff/center.o | Bin 0 -> 1480 bytes pkg/system/help/lroff/center.x | 32 + pkg/system/help/lroff/dols.o | Bin 0 -> 2792 bytes pkg/system/help/lroff/dols.x | 108 + pkg/system/help/lroff/getarg.o | Bin 0 -> 944 bytes pkg/system/help/lroff/getarg.x | 35 + pkg/system/help/lroff/indent.o | Bin 0 -> 948 bytes pkg/system/help/lroff/indent.x | 17 + pkg/system/help/lroff/input.o | Bin 0 -> 2608 bytes pkg/system/help/lroff/input.x | 123 + pkg/system/help/lroff/justify.o | Bin 0 -> 2064 bytes pkg/system/help/lroff/justify.x | 63 + pkg/system/help/lroff/lroff.com | 24 + pkg/system/help/lroff/lroff.h | 41 + pkg/system/help/lroff/lroff.hlp | 258 + pkg/system/help/lroff/lroff.o | Bin 0 -> 5952 bytes pkg/system/help/lroff/lroff.x | 220 + pkg/system/help/lroff/lroff2html.c | 1381 ++ pkg/system/help/lroff/lroff2html.x | 781 ++ pkg/system/help/lroff/lroff2ps.x | 460 + pkg/system/help/lroff/mkpkg | 27 + pkg/system/help/lroff/nextcmd.x | 56 + pkg/system/help/lroff/nofill.x | 45 + pkg/system/help/lroff/output.x | 190 + pkg/system/help/lroff/rawcopy.x | 26 + pkg/system/help/lroff/section.x | 224 + pkg/system/help/lroff/skiplines.x | 19 + pkg/system/help/lroff/textlen.x | 20 + pkg/system/help/lroff/textout.x | 140 + pkg/system/help/lroff/words.com | 9 + pkg/system/help/manout.x | 330 + pkg/system/help/mkhelpdb.hlp | 75 + pkg/system/help/mkpkg | 36 + pkg/system/help/modlist.x | 200 + pkg/system/help/modtemp.x | 190 + pkg/system/help/prblkhdr.x | 80 + pkg/system/help/prdir.x | 108 + pkg/system/help/prfile.x | 84 + pkg/system/help/prfnames.x | 69 + pkg/system/help/prhelp.x | 144 + pkg/system/help/prhlpblk.x | 154 + pkg/system/help/prmodname.x | 35 + pkg/system/help/prsummary.x | 95 + pkg/system/help/t_hdbexamine.x | 35 + pkg/system/help/t_help.x | 290 + pkg/system/help/t_lroff.x | 35 + pkg/system/help/t_mkhelpdb.x | 76 + pkg/system/help/tlist.x | 406 + pkg/system/help/xhelp/help.gui | 3027 +++++ pkg/system/help/xhelp/mkpkg | 28 + pkg/system/help/xhelp/xhcmds.x | 185 + pkg/system/help/xhelp/xhdir.x | 567 + pkg/system/help/xhelp/xhelp.h | 89 + pkg/system/help/xhelp/xhelp.x | 167 + pkg/system/help/xhelp/xhfiles.x | 89 + pkg/system/help/xhelp/xhhelp.x | 276 + pkg/system/help/xhelp/xhinit.x | 77 + pkg/system/help/xhelp/xhofile.x | 188 + pkg/system/help/xhelp/xhpkg.x | 192 + pkg/system/help/xhelp/xhprint.x | 151 + pkg/system/help/xhelp/xhqref.x | 250 + pkg/system/help/xhelp/xhroot.x | 73 + pkg/system/help/xhelp/xhsave.x | 184 + pkg/system/help/xhelp/xhsearch.x | 185 + pkg/system/help/xhelp/xhsort.x | 223 + pkg/system/help/xhelp/zzdebug.x | 59 + pkg/system/lprint.par | 5 + pkg/system/lprint.x | 213 + pkg/system/lroff.par | 4 + pkg/system/match.par | 5 + pkg/system/match.x | 96 + pkg/system/mkdir.par | 1 + pkg/system/mkdir.x | 12 + pkg/system/mkhelpdb.par | 3 + pkg/system/mkpkg | 53 + pkg/system/mkscript.cl | 79 + pkg/system/mkscript.par | 17 + pkg/system/movefiles.par | 3 + pkg/system/movefiles.x | 52 + pkg/system/mtclean.par | 3 + pkg/system/mtclean.x | 25 + pkg/system/netstatus.x | 9 + pkg/system/news.cl | 5 + pkg/system/page.par | 6 + pkg/system/page.x | 41 + pkg/system/pathnames.par | 2 + pkg/system/pathnames.x | 55 + pkg/system/phelp.cl | 41 + pkg/system/protect.par | 1 + pkg/system/protect.x | 23 + pkg/system/references.cl | 50 + pkg/system/rename.par | 3 + pkg/system/rename.x | 176 + pkg/system/rewind.par | 2 + pkg/system/rewind.x | 14 + pkg/system/sort.com | 10 + pkg/system/sort.par | 5 + pkg/system/sort.x | 434 + pkg/system/system.cl | 55 + pkg/system/system.hd | 47 + pkg/system/system.men | 39 + pkg/system/system.par | 5 + pkg/system/t_fcache.x | 118 + pkg/system/t_urlget.x | 96 + pkg/system/tail.par | 2 + pkg/system/tail.x | 107 + pkg/system/tee.par | 3 + pkg/system/tee.x | 58 + pkg/system/touch.par | 7 + pkg/system/touch.x | 193 + pkg/system/type.par | 3 + pkg/system/type.x | 68 + pkg/system/unprotect.par | 1 + pkg/system/unprotect.x | 23 + pkg/system/urlget.par | 6 + pkg/system/x_system.x | 36 + pkg/tbtables/README | 11 + pkg/tbtables/Revisions | 16 + pkg/tbtables/cfitsio/Licence.txt | 46 + pkg/tbtables/cfitsio/Makefile.in | 145 + pkg/tbtables/cfitsio/README | 151 + pkg/tbtables/cfitsio/README.MacOS | 31 + pkg/tbtables/cfitsio/buffers.c | 1448 +++ pkg/tbtables/cfitsio/cfileio.c | 5572 ++++++++ pkg/tbtables/cfitsio/cfitsio.doc | 8406 ++++++++++++ pkg/tbtables/cfitsio/cfitsio.ps | 12896 +++++++++++++++++++ pkg/tbtables/cfitsio/cfitsio.tex | 9422 ++++++++++++++ pkg/tbtables/cfitsio/cfitsio.toc | 118 + pkg/tbtables/cfitsio/cfitsio_mac.sit.hqx | 1 + pkg/tbtables/cfitsio/cfortran.doc | 2051 +++ pkg/tbtables/cfitsio/cfortran.h | 2397 ++++ pkg/tbtables/cfitsio/changes.txt | 2521 ++++ pkg/tbtables/cfitsio/checksum.c | 508 + pkg/tbtables/cfitsio/compress.c | 155 + pkg/tbtables/cfitsio/compress.h | 212 + pkg/tbtables/cfitsio/configure | 1886 +++ pkg/tbtables/cfitsio/configure.in | 352 + pkg/tbtables/cfitsio/cookbook.c | 571 + pkg/tbtables/cfitsio/cookbook.f | 772 ++ pkg/tbtables/cfitsio/drvrfile.c | 730 ++ pkg/tbtables/cfitsio/drvrmem.c | 1163 ++ pkg/tbtables/cfitsio/drvrnet.c | 2587 ++++ pkg/tbtables/cfitsio/drvrsmem.c | 953 ++ pkg/tbtables/cfitsio/drvrsmem.h | 179 + pkg/tbtables/cfitsio/editcol.c | 2068 +++ pkg/tbtables/cfitsio/edithdu.c | 793 ++ pkg/tbtables/cfitsio/eval.l | 512 + pkg/tbtables/cfitsio/eval.y | 5227 ++++++++ pkg/tbtables/cfitsio/eval_defs.h | 153 + pkg/tbtables/cfitsio/eval_f.c | 2293 ++++ pkg/tbtables/cfitsio/eval_l.c | 2219 ++++ pkg/tbtables/cfitsio/eval_tab.h | 41 + pkg/tbtables/cfitsio/eval_y.c | 6686 ++++++++++ pkg/tbtables/cfitsio/f77.inc | 31 + pkg/tbtables/cfitsio/f77_wrap.h | 278 + pkg/tbtables/cfitsio/f77_wrap1.c | 960 ++ pkg/tbtables/cfitsio/f77_wrap2.c | 1081 ++ pkg/tbtables/cfitsio/fitscopy.c | 64 + pkg/tbtables/cfitsio/fitscore.c | 7007 ++++++++++ pkg/tbtables/cfitsio/fitsio.doc | 6137 +++++++++ pkg/tbtables/cfitsio/fitsio.h | 1565 +++ pkg/tbtables/cfitsio/fitsio.ps | 9852 ++++++++++++++ pkg/tbtables/cfitsio/fitsio.tex | 7203 +++++++++++ pkg/tbtables/cfitsio/fitsio.toc | 90 + pkg/tbtables/cfitsio/fitsio2.h | 1135 ++ pkg/tbtables/cfitsio/getcol.c | 919 ++ pkg/tbtables/cfitsio/getcolb.c | 2111 +++ pkg/tbtables/cfitsio/getcold.c | 1768 +++ pkg/tbtables/cfitsio/getcole.c | 1775 +++ pkg/tbtables/cfitsio/getcoli.c | 2043 +++ pkg/tbtables/cfitsio/getcolj.c | 3856 ++++++ pkg/tbtables/cfitsio/getcolk.c | 2037 +++ pkg/tbtables/cfitsio/getcoll.c | 612 + pkg/tbtables/cfitsio/getcols.c | 743 ++ pkg/tbtables/cfitsio/getcolsb.c | 2133 +++ pkg/tbtables/cfitsio/getcolui.c | 2050 +++ pkg/tbtables/cfitsio/getcoluj.c | 2044 +++ pkg/tbtables/cfitsio/getcoluk.c | 2059 +++ pkg/tbtables/cfitsio/getkey.c | 2544 ++++ pkg/tbtables/cfitsio/group.c | 6418 +++++++++ pkg/tbtables/cfitsio/group.h | 65 + pkg/tbtables/cfitsio/grparser.c | 1365 ++ pkg/tbtables/cfitsio/grparser.h | 185 + pkg/tbtables/cfitsio/histo.c | 1300 ++ pkg/tbtables/cfitsio/imcompress.c | 2997 +++++ pkg/tbtables/cfitsio/iraffits.c | 1975 +++ pkg/tbtables/cfitsio/iter_a.c | 147 + pkg/tbtables/cfitsio/iter_a.f | 224 + pkg/tbtables/cfitsio/iter_a.fit | 1111 ++ pkg/tbtables/cfitsio/iter_b.c | 114 + pkg/tbtables/cfitsio/iter_b.f | 193 + pkg/tbtables/cfitsio/iter_b.fit | Bin 0 -> 408960 bytes pkg/tbtables/cfitsio/iter_c.c | 171 + pkg/tbtables/cfitsio/iter_c.f | 347 + pkg/tbtables/cfitsio/iter_c.fit | 701 + pkg/tbtables/cfitsio/listhead.c | 62 + pkg/tbtables/cfitsio/longnam.h | 538 + pkg/tbtables/cfitsio/make_dfloat.com | 83 + pkg/tbtables/cfitsio/make_gfloat.com | 81 + pkg/tbtables/cfitsio/make_ieee.com | 80 + pkg/tbtables/cfitsio/makefile.bc | 496 + pkg/tbtables/cfitsio/makefile.os2 | 22 + pkg/tbtables/cfitsio/makefile.vcc | 691 + pkg/tbtables/cfitsio/makepc.bat | 69 + pkg/tbtables/cfitsio/mkpkg | 66 + pkg/tbtables/cfitsio/modkey.c | 1614 +++ pkg/tbtables/cfitsio/pctype.h | 155 + pkg/tbtables/cfitsio/pliocomp.c | 331 + pkg/tbtables/cfitsio/putcol.c | 1714 +++ pkg/tbtables/cfitsio/putcolb.c | 1031 ++ pkg/tbtables/cfitsio/putcold.c | 1147 ++ pkg/tbtables/cfitsio/putcole.c | 1154 ++ pkg/tbtables/cfitsio/putcoli.c | 1039 ++ pkg/tbtables/cfitsio/putcolj.c | 2018 +++ pkg/tbtables/cfitsio/putcolk.c | 1067 ++ pkg/tbtables/cfitsio/putcoll.c | 355 + pkg/tbtables/cfitsio/putcols.c | 284 + pkg/tbtables/cfitsio/putcolsb.c | 1030 ++ pkg/tbtables/cfitsio/putcolu.c | 587 + pkg/tbtables/cfitsio/putcolui.c | 1022 ++ pkg/tbtables/cfitsio/putcoluj.c | 1029 ++ pkg/tbtables/cfitsio/putcoluk.c | 1046 ++ pkg/tbtables/cfitsio/putkey.c | 2706 ++++ pkg/tbtables/cfitsio/quantize.c | 613 + pkg/tbtables/cfitsio/quick.ps | 3850 ++++++ pkg/tbtables/cfitsio/quick.tex | 2156 ++++ pkg/tbtables/cfitsio/quick.toc | 25 + pkg/tbtables/cfitsio/region.c | 919 ++ pkg/tbtables/cfitsio/region.h | 80 + pkg/tbtables/cfitsio/ricecomp.c | 510 + pkg/tbtables/cfitsio/ricecomp.h | 107 + pkg/tbtables/cfitsio/sample.tpl | 121 + pkg/tbtables/cfitsio/scalnull.c | 230 + pkg/tbtables/cfitsio/smem.c | 67 + pkg/tbtables/cfitsio/speed.c | 485 + pkg/tbtables/cfitsio/swapproc.c | 98 + pkg/tbtables/cfitsio/testf77.f | 2488 ++++ pkg/tbtables/cfitsio/testf77.out | 746 ++ pkg/tbtables/cfitsio/testf77.std | Bin 0 -> 66240 bytes pkg/tbtables/cfitsio/testprog.c | 2588 ++++ pkg/tbtables/cfitsio/testprog.out | 797 ++ pkg/tbtables/cfitsio/testprog.std | 48 + pkg/tbtables/cfitsio/testprog.tpt | 12 + pkg/tbtables/cfitsio/vmsieee.c | 130 + pkg/tbtables/cfitsio/vmsieeed.mar | 137 + pkg/tbtables/cfitsio/vmsieeer.mar | 106 + pkg/tbtables/cfitsio/wcssub.c | 327 + pkg/tbtables/cfitsio/wcsutil.c | 72 + pkg/tbtables/cfitsio/wcsutil.c.OLD | 786 ++ pkg/tbtables/cfitsio/winDumpExts.mak | 191 + pkg/tbtables/cfitsio/windumpexts.c | 503 + pkg/tbtables/doc/Notes | 46 + pkg/tbtables/doc/README | 10 + pkg/tbtables/doc/calls.doc | 190 + pkg/tbtables/doc/cfitsio.install | 57 + pkg/tbtables/doc/descrip.doc | 62 + pkg/tbtables/doc/ex.x | 109 + pkg/tbtables/doc/example.doc | 122 + pkg/tbtables/doc/fileformat.doc | 91 + pkg/tbtables/doc/tbtcpy.lis | 30 + pkg/tbtables/doc/text_tables.doc | 234 + pkg/tbtables/doc/versions.doc | 29 + pkg/tbtables/fitsio/README | 11 + pkg/tbtables/fitsio/fitsspp.com | 23 + pkg/tbtables/fitsio/fitsspp.x | 831 ++ pkg/tbtables/fitsio/fitssppb/README | 14 + pkg/tbtables/fitsio/fitssppb/fitsio.h | 15 + pkg/tbtables/fitsio/fitssppb/fsadef.x | 24 + pkg/tbtables/fitsio/fitssppb/fsarch.x | 9 + pkg/tbtables/fitsio/fitssppb/fsasfm.x | 15 + pkg/tbtables/fitsio/fitssppb/fsbdef.x | 23 + pkg/tbtables/fitsio/fitssppb/fsbnfm.x | 21 + pkg/tbtables/fitsio/fitssppb/fsclos.x | 13 + pkg/tbtables/fitsio/fitssppb/fscmps.x | 18 + pkg/tbtables/fitsio/fitssppb/fscmsg.x | 11 + pkg/tbtables/fitsio/fitssppb/fscopy.x | 17 + pkg/tbtables/fitsio/fitssppb/fscpdt.x | 15 + pkg/tbtables/fitsio/fitssppb/fscrhd.x | 15 + pkg/tbtables/fitsio/fitssppb/fsdcol.x | 14 + pkg/tbtables/fitsio/fitssppb/fsddef.x | 16 + pkg/tbtables/fitsio/fitssppb/fsdelt.x | 13 + pkg/tbtables/fitsio/fitssppb/fsdhdu.x | 14 + pkg/tbtables/fitsio/fitssppb/fsdkey.x | 17 + pkg/tbtables/fitsio/fitssppb/fsdrec.x | 14 + pkg/tbtables/fitsio/fitssppb/fsdrow.x | 15 + pkg/tbtables/fitsio/fitssppb/fsdsum.x | 14 + pkg/tbtables/fitsio/fitssppb/fsdtyp.x | 26 + pkg/tbtables/fitsio/fitssppb/fsesum.x | 14 + pkg/tbtables/fitsio/fitssppb/fsfiou.x | 13 + pkg/tbtables/fitsio/fitssppb/fsg2db.x | 23 + pkg/tbtables/fitsio/fitssppb/fsg2dd.x | 23 + pkg/tbtables/fitsio/fitssppb/fsg2de.x | 23 + pkg/tbtables/fitsio/fitssppb/fsg2di.x | 23 + pkg/tbtables/fitsio/fitssppb/fsg2dj.x | 23 + pkg/tbtables/fitsio/fitssppb/fsg3db.x | 27 + pkg/tbtables/fitsio/fitssppb/fsg3dd.x | 27 + pkg/tbtables/fitsio/fitssppb/fsg3de.x | 27 + pkg/tbtables/fitsio/fitssppb/fsg3di.x | 27 + pkg/tbtables/fitsio/fitssppb/fsg3dj.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgabc.x | 24 + pkg/tbtables/fitsio/fitssppb/fsgacl.x | 33 + pkg/tbtables/fitsio/fitssppb/fsgbcl.x | 32 + pkg/tbtables/fitsio/fitssppb/fsgcfb.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcfc.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcfd.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcfe.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcfi.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcfj.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcfl.x | 24 + pkg/tbtables/fitsio/fitssppb/fsgcfm.x | 26 + pkg/tbtables/fitsio/fitssppb/fsgcfs.x | 38 + pkg/tbtables/fitsio/fitssppb/fsgcks.x | 13 + pkg/tbtables/fitsio/fitssppb/fsgcl.x | 21 + pkg/tbtables/fitsio/fitssppb/fsgcnn.x | 21 + pkg/tbtables/fitsio/fitssppb/fsgcno.x | 20 + pkg/tbtables/fitsio/fitssppb/fsgcrd.x | 21 + pkg/tbtables/fitsio/fitssppb/fsgcvb.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcvc.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcvd.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcve.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcvi.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcvj.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgcvm.x | 26 + pkg/tbtables/fitsio/fitssppb/fsgcvs.x | 41 + pkg/tbtables/fitsio/fitssppb/fsgcx.x | 23 + pkg/tbtables/fitsio/fitssppb/fsgcxd.x | 19 + pkg/tbtables/fitsio/fitssppb/fsgcxi.x | 19 + pkg/tbtables/fitsio/fitssppb/fsgcxj.x | 19 + pkg/tbtables/fitsio/fitssppb/fsgdes.x | 19 + pkg/tbtables/fitsio/fitssppb/fsgerr.x | 16 + pkg/tbtables/fitsio/fitssppb/fsggpb.x | 20 + pkg/tbtables/fitsio/fitssppb/fsggpd.x | 20 + pkg/tbtables/fitsio/fitssppb/fsggpe.x | 20 + pkg/tbtables/fitsio/fitssppb/fsggpi.x | 20 + pkg/tbtables/fitsio/fitssppb/fsggpj.x | 20 + pkg/tbtables/fitsio/fitssppb/fsghad.x | 14 + pkg/tbtables/fitsio/fitssppb/fsghbn.x | 38 + pkg/tbtables/fitsio/fitssppb/fsghdn.x | 14 + pkg/tbtables/fitsio/fitssppb/fsghpr.x | 23 + pkg/tbtables/fitsio/fitssppb/fsghps.x | 15 + pkg/tbtables/fitsio/fitssppb/fsghsp.x | 16 + pkg/tbtables/fitsio/fitssppb/fsghtb.x | 40 + pkg/tbtables/fitsio/fitssppb/fsgics.x | 16 + pkg/tbtables/fitsio/fitssppb/fsgiou.x | 13 + pkg/tbtables/fitsio/fitssppb/fsgkey.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgknd.x | 21 + pkg/tbtables/fitsio/fitssppb/fsgkne.x | 21 + pkg/tbtables/fitsio/fitssppb/fsgknj.x | 21 + pkg/tbtables/fitsio/fitssppb/fsgknl.x | 21 + pkg/tbtables/fitsio/fitssppb/fsgkns.x | 49 + pkg/tbtables/fitsio/fitssppb/fsgkyd.x | 22 + pkg/tbtables/fitsio/fitssppb/fsgkye.x | 22 + pkg/tbtables/fitsio/fitssppb/fsgkyj.x | 22 + pkg/tbtables/fitsio/fitssppb/fsgkyl.x | 22 + pkg/tbtables/fitsio/fitssppb/fsgkyn.x | 26 + pkg/tbtables/fitsio/fitssppb/fsgkys.x | 25 + pkg/tbtables/fitsio/fitssppb/fsgkyt.x | 24 + pkg/tbtables/fitsio/fitssppb/fsgmsg.x | 15 + pkg/tbtables/fitsio/fitssppb/fsgpfb.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgpfd.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgpfe.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgpfi.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgpfj.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgpvb.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgpvd.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgpve.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgpvi.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgpvj.x | 27 + pkg/tbtables/fitsio/fitssppb/fsgrec.x | 20 + pkg/tbtables/fitsio/fitssppb/fsgrsz.x | 35 + pkg/tbtables/fitsio/fitssppb/fsgsdt.x | 14 + pkg/tbtables/fitsio/fitssppb/fsgsfb.x | 23 + pkg/tbtables/fitsio/fitssppb/fsgsfd.x | 23 + pkg/tbtables/fitsio/fitssppb/fsgsfe.x | 24 + pkg/tbtables/fitsio/fitssppb/fsgsfi.x | 24 + pkg/tbtables/fitsio/fitssppb/fsgsfj.x | 24 + pkg/tbtables/fitsio/fitssppb/fsgsvb.x | 23 + pkg/tbtables/fitsio/fitssppb/fsgsvd.x | 23 + pkg/tbtables/fitsio/fitssppb/fsgsve.x | 24 + pkg/tbtables/fitsio/fitssppb/fsgsvi.x | 24 + pkg/tbtables/fitsio/fitssppb/fsgsvj.x | 24 + pkg/tbtables/fitsio/fitssppb/fsgtbb.x | 19 + pkg/tbtables/fitsio/fitssppb/fsgtbs.x | 38 + pkg/tbtables/fitsio/fitssppb/fsgtcl.x | 12 + pkg/tbtables/fitsio/fitssppb/fsgtcs.x | 18 + pkg/tbtables/fitsio/fitssppb/fsgtdm.x | 17 + pkg/tbtables/fitsio/fitssppb/fsgthd.x | 23 + pkg/tbtables/fitsio/fitssppb/fshdef.x | 16 + pkg/tbtables/fitsio/fitssppb/fsibin.x | 35 + pkg/tbtables/fitsio/fitssppb/fsicol.x | 21 + pkg/tbtables/fitsio/fitssppb/fsiimg.x | 16 + pkg/tbtables/fitsio/fitssppb/fsikyd.x | 25 + pkg/tbtables/fitsio/fitssppb/fsikye.x | 22 + pkg/tbtables/fitsio/fitssppb/fsikyf.x | 22 + pkg/tbtables/fitsio/fitssppb/fsikyg.x | 22 + pkg/tbtables/fitsio/fitssppb/fsikyj.x | 21 + pkg/tbtables/fitsio/fitssppb/fsikyl.x | 21 + pkg/tbtables/fitsio/fitssppb/fsikys.x | 23 + pkg/tbtables/fitsio/fitssppb/fsinit.x | 18 + pkg/tbtables/fitsio/fitssppb/fsirec.x | 18 + pkg/tbtables/fitsio/fitssppb/fsirow.x | 15 + pkg/tbtables/fitsio/fitssppb/fsitab.x | 36 + pkg/tbtables/fitsio/fitssppb/fskeyn.x | 22 + pkg/tbtables/fitsio/fitssppb/fsmahd.x | 17 + pkg/tbtables/fitsio/fitssppb/fsmcom.x | 20 + pkg/tbtables/fitsio/fitssppb/fsmcrd.x | 22 + pkg/tbtables/fitsio/fitssppb/fsmkyd.x | 25 + pkg/tbtables/fitsio/fitssppb/fsmkye.x | 22 + pkg/tbtables/fitsio/fitssppb/fsmkyf.x | 22 + pkg/tbtables/fitsio/fitssppb/fsmkyg.x | 22 + pkg/tbtables/fitsio/fitssppb/fsmkyj.x | 21 + pkg/tbtables/fitsio/fitssppb/fsmkyl.x | 21 + pkg/tbtables/fitsio/fitssppb/fsmkys.x | 23 + pkg/tbtables/fitsio/fitssppb/fsmnam.x | 20 + pkg/tbtables/fitsio/fitssppb/fsmrec.x | 19 + pkg/tbtables/fitsio/fitssppb/fsmrhd.x | 17 + pkg/tbtables/fitsio/fitssppb/fsnkey.x | 22 + pkg/tbtables/fitsio/fitssppb/fsopen.x | 19 + pkg/tbtables/fitsio/fitssppb/fsp2db.x | 21 + pkg/tbtables/fitsio/fitssppb/fsp2dd.x | 21 + pkg/tbtables/fitsio/fitssppb/fsp2de.x | 21 + pkg/tbtables/fitsio/fitssppb/fsp2di.x | 21 + pkg/tbtables/fitsio/fitssppb/fsp2dj.x | 21 + pkg/tbtables/fitsio/fitssppb/fsp3db.x | 23 + pkg/tbtables/fitsio/fitssppb/fsp3dd.x | 23 + pkg/tbtables/fitsio/fitssppb/fsp3de.x | 23 + pkg/tbtables/fitsio/fitssppb/fsp3di.x | 23 + pkg/tbtables/fitsio/fitssppb/fsp3dj.x | 23 + pkg/tbtables/fitsio/fitssppb/fspcks.x | 11 + pkg/tbtables/fitsio/fitssppb/fspclb.x | 19 + pkg/tbtables/fitsio/fitssppb/fspclc.x | 21 + pkg/tbtables/fitsio/fitssppb/fspcld.x | 19 + pkg/tbtables/fitsio/fitssppb/fspcle.x | 19 + pkg/tbtables/fitsio/fitssppb/fspcli.x | 19 + pkg/tbtables/fitsio/fitssppb/fspclj.x | 19 + pkg/tbtables/fitsio/fitssppb/fspcll.x | 20 + pkg/tbtables/fitsio/fitssppb/fspclm.x | 21 + pkg/tbtables/fitsio/fitssppb/fspcls.x | 29 + pkg/tbtables/fitsio/fitssppb/fspclu.x | 17 + pkg/tbtables/fitsio/fitssppb/fspclx.x | 23 + pkg/tbtables/fitsio/fitssppb/fspcnb.x | 20 + pkg/tbtables/fitsio/fitssppb/fspcnd.x | 20 + pkg/tbtables/fitsio/fitssppb/fspcne.x | 20 + pkg/tbtables/fitsio/fitssppb/fspcni.x | 20 + pkg/tbtables/fitsio/fitssppb/fspcnj.x | 20 + pkg/tbtables/fitsio/fitssppb/fspcom.x | 17 + pkg/tbtables/fitsio/fitssppb/fspdat.x | 13 + pkg/tbtables/fitsio/fitssppb/fspdef.x | 19 + pkg/tbtables/fitsio/fitssppb/fspdes.x | 19 + pkg/tbtables/fitsio/fitssppb/fspgpb.x | 20 + pkg/tbtables/fitsio/fitssppb/fspgpd.x | 20 + pkg/tbtables/fitsio/fitssppb/fspgpe.x | 20 + pkg/tbtables/fitsio/fitssppb/fspgpi.x | 20 + pkg/tbtables/fitsio/fitssppb/fspgpj.x | 20 + pkg/tbtables/fitsio/fitssppb/fsphbn.x | 35 + pkg/tbtables/fitsio/fitssppb/fsphis.x | 17 + pkg/tbtables/fitsio/fitssppb/fsphpr.x | 22 + pkg/tbtables/fitsio/fitssppb/fsphtb.x | 36 + pkg/tbtables/fitsio/fitssppb/fspkls.x | 23 + pkg/tbtables/fitsio/fitssppb/fspknd.x | 27 + pkg/tbtables/fitsio/fitssppb/fspkne.x | 27 + pkg/tbtables/fitsio/fitssppb/fspknf.x | 27 + pkg/tbtables/fitsio/fitssppb/fspkng.x | 27 + pkg/tbtables/fitsio/fitssppb/fspknj.x | 26 + pkg/tbtables/fitsio/fitssppb/fspknl.x | 26 + pkg/tbtables/fitsio/fitssppb/fspkns.x | 34 + pkg/tbtables/fitsio/fitssppb/fspkyd.x | 25 + pkg/tbtables/fitsio/fitssppb/fspkye.x | 22 + pkg/tbtables/fitsio/fitssppb/fspkyf.x | 22 + pkg/tbtables/fitsio/fitssppb/fspkyg.x | 22 + pkg/tbtables/fitsio/fitssppb/fspkyj.x | 21 + pkg/tbtables/fitsio/fitssppb/fspkyl.x | 21 + pkg/tbtables/fitsio/fitssppb/fspkys.x | 23 + pkg/tbtables/fitsio/fitssppb/fspkyt.x | 24 + pkg/tbtables/fitsio/fitssppb/fsplsw.x | 13 + pkg/tbtables/fitsio/fitssppb/fspmsg.x | 15 + pkg/tbtables/fitsio/fitssppb/fspnul.x | 16 + pkg/tbtables/fitsio/fitssppb/fsppnb.x | 21 + pkg/tbtables/fitsio/fitssppb/fsppnd.x | 21 + pkg/tbtables/fitsio/fitssppb/fsppne.x | 21 + pkg/tbtables/fitsio/fitssppb/fsppni.x | 21 + pkg/tbtables/fitsio/fitssppb/fsppnj.x | 21 + pkg/tbtables/fitsio/fitssppb/fspprb.x | 20 + pkg/tbtables/fitsio/fitssppb/fspprd.x | 20 + pkg/tbtables/fitsio/fitssppb/fsppre.x | 20 + pkg/tbtables/fitsio/fitssppb/fsppri.x | 20 + pkg/tbtables/fitsio/fitssppb/fspprj.x | 20 + pkg/tbtables/fitsio/fitssppb/fsppru.x | 16 + pkg/tbtables/fitsio/fitssppb/fsprec.x | 17 + pkg/tbtables/fitsio/fitssppb/fspscl.x | 17 + pkg/tbtables/fitsio/fitssppb/fspssb.x | 24 + pkg/tbtables/fitsio/fitssppb/fspssd.x | 24 + pkg/tbtables/fitsio/fitssppb/fspsse.x | 24 + pkg/tbtables/fitsio/fitssppb/fspssi.x | 24 + pkg/tbtables/fitsio/fitssppb/fspssj.x | 24 + pkg/tbtables/fitsio/fitssppb/fspsvc.x | 23 + pkg/tbtables/fitsio/fitssppb/fsptbb.x | 19 + pkg/tbtables/fitsio/fitssppb/fsptbs.x | 38 + pkg/tbtables/fitsio/fitssppb/fsptdm.x | 16 + pkg/tbtables/fitsio/fitssppb/fspthp.x | 18 + pkg/tbtables/fitsio/fitssppb/fsrdef.x | 15 + pkg/tbtables/fitsio/fitssppb/fssnul.x | 19 + pkg/tbtables/fitsio/fitssppb/fstkey.x | 17 + pkg/tbtables/fitsio/fitssppb/fstnul.x | 16 + pkg/tbtables/fitsio/fitssppb/fstscl.x | 17 + pkg/tbtables/fitsio/fitssppb/fsucks.x | 11 + pkg/tbtables/fitsio/fitssppb/fsucrd.x | 21 + pkg/tbtables/fitsio/fitssppb/fsukyd.x | 25 + pkg/tbtables/fitsio/fitssppb/fsukye.x | 22 + pkg/tbtables/fitsio/fitssppb/fsukyf.x | 22 + pkg/tbtables/fitsio/fitssppb/fsukyg.x | 22 + pkg/tbtables/fitsio/fitssppb/fsukyj.x | 21 + pkg/tbtables/fitsio/fitssppb/fsukyl.x | 21 + pkg/tbtables/fitsio/fitssppb/fsukys.x | 23 + pkg/tbtables/fitsio/fitssppb/fsvcks.x | 13 + pkg/tbtables/fitsio/fitssppb/fsvers.x | 14 + pkg/tbtables/fitsio/fitssppb/fswldp.x | 17 + pkg/tbtables/fitsio/fitssppb/fsxypx.x | 17 + pkg/tbtables/fitsio/fitssppb/mkpkg | 262 + pkg/tbtables/fitsio/ftadef.f | 143 + pkg/tbtables/fitsio/ftaini.f | 183 + pkg/tbtables/fitsio/ftarch.f | 40 + pkg/tbtables/fitsio/ftas2c.f | 52 + pkg/tbtables/fitsio/ftasfm.f | 143 + pkg/tbtables/fitsio/ftbdef.f | 121 + pkg/tbtables/fitsio/ftbini.f | 181 + pkg/tbtables/fitsio/ftbnfm.f | 137 + pkg/tbtables/fitsio/ftc2as.f | 54 + pkg/tbtables/fitsio/ftc2d.f | 38 + pkg/tbtables/fitsio/ftc2dd.f | 37 + pkg/tbtables/fitsio/ftc2i.f | 37 + pkg/tbtables/fitsio/ftc2ii.f | 37 + pkg/tbtables/fitsio/ftc2l.f | 26 + pkg/tbtables/fitsio/ftc2ll.f | 18 + pkg/tbtables/fitsio/ftc2r.f | 40 + pkg/tbtables/fitsio/ftc2rr.f | 39 + pkg/tbtables/fitsio/ftc2s.f | 65 + pkg/tbtables/fitsio/ftc2x.f | 37 + pkg/tbtables/fitsio/ftcdel.f | 136 + pkg/tbtables/fitsio/ftcdfl.f | 80 + pkg/tbtables/fitsio/ftchdu.f | 58 + pkg/tbtables/fitsio/ftchfl.f | 72 + pkg/tbtables/fitsio/ftcins.f | 173 + pkg/tbtables/fitsio/ftclos.f | 21 + pkg/tbtables/fitsio/ftcmps.f | 104 + pkg/tbtables/fitsio/ftcmsg.f | 6 + pkg/tbtables/fitsio/ftcopy.f | 84 + pkg/tbtables/fitsio/ftcpdt.f | 58 + pkg/tbtables/fitsio/ftcrep.f | 29 + pkg/tbtables/fitsio/ftcrhd.f | 53 + pkg/tbtables/fitsio/ftcsum.f | 52 + pkg/tbtables/fitsio/ftd2e.f | 43 + pkg/tbtables/fitsio/ftd2f.f | 36 + pkg/tbtables/fitsio/ftdblk.f | 98 + pkg/tbtables/fitsio/ftdcol.f | 132 + pkg/tbtables/fitsio/ftddef.f | 54 + pkg/tbtables/fitsio/ftdelt.f | 39 + pkg/tbtables/fitsio/ftdhdu.f | 58 + pkg/tbtables/fitsio/ftdkey.f | 55 + pkg/tbtables/fitsio/ftdrec.f | 64 + pkg/tbtables/fitsio/ftdrow.f | 94 + pkg/tbtables/fitsio/ftdsum.f | 68 + pkg/tbtables/fitsio/ftdtyp.f | 35 + pkg/tbtables/fitsio/ftesum.f | 94 + pkg/tbtables/fitsio/ftfiou.f | 11 + pkg/tbtables/fitsio/ftfrcl.f | 91 + pkg/tbtables/fitsio/ftg2db.f | 36 + pkg/tbtables/fitsio/ftg2dd.f | 36 + pkg/tbtables/fitsio/ftg2de.f | 36 + pkg/tbtables/fitsio/ftg2di.f | 36 + pkg/tbtables/fitsio/ftg2dj.f | 36 + pkg/tbtables/fitsio/ftg3db.f | 39 + pkg/tbtables/fitsio/ftg3dd.f | 39 + pkg/tbtables/fitsio/ftg3de.f | 39 + pkg/tbtables/fitsio/ftg3di.f | 39 + pkg/tbtables/fitsio/ftg3dj.f | 39 + pkg/tbtables/fitsio/ftgabc.f | 49 + pkg/tbtables/fitsio/ftgacl.f | 70 + pkg/tbtables/fitsio/ftgatp.f | 169 + pkg/tbtables/fitsio/ftgbcl.f | 119 + pkg/tbtables/fitsio/ftgbit.f | 68 + pkg/tbtables/fitsio/ftgbnh.f | 12 + pkg/tbtables/fitsio/ftgbtp.f | 119 + pkg/tbtables/fitsio/ftgcfb.f | 33 + pkg/tbtables/fitsio/ftgcfc.f | 33 + pkg/tbtables/fitsio/ftgcfd.f | 33 + pkg/tbtables/fitsio/ftgcfe.f | 33 + pkg/tbtables/fitsio/ftgcfi.f | 33 + pkg/tbtables/fitsio/ftgcfj.f | 32 + pkg/tbtables/fitsio/ftgcfl.f | 150 + pkg/tbtables/fitsio/ftgcfm.f | 34 + pkg/tbtables/fitsio/ftgcfs.f | 34 + pkg/tbtables/fitsio/ftgcks.f | 54 + pkg/tbtables/fitsio/ftgcl.f | 184 + pkg/tbtables/fitsio/ftgclb.f | 380 + pkg/tbtables/fitsio/ftgclc.f | 238 + pkg/tbtables/fitsio/ftgcld.f | 382 + pkg/tbtables/fitsio/ftgcle.f | 382 + pkg/tbtables/fitsio/ftgcli.f | 382 + pkg/tbtables/fitsio/ftgclj.f | 384 + pkg/tbtables/fitsio/ftgclm.f | 239 + pkg/tbtables/fitsio/ftgcls.f | 207 + pkg/tbtables/fitsio/ftgcnn.f | 140 + pkg/tbtables/fitsio/ftgcno.f | 22 + pkg/tbtables/fitsio/ftgcrd.f | 76 + pkg/tbtables/fitsio/ftgcvb.f | 29 + pkg/tbtables/fitsio/ftgcvc.f | 28 + pkg/tbtables/fitsio/ftgcvd.f | 29 + pkg/tbtables/fitsio/ftgcve.f | 28 + pkg/tbtables/fitsio/ftgcvi.f | 28 + pkg/tbtables/fitsio/ftgcvj.f | 28 + pkg/tbtables/fitsio/ftgcvm.f | 29 + pkg/tbtables/fitsio/ftgcvs.f | 28 + pkg/tbtables/fitsio/ftgcx.f | 140 + pkg/tbtables/fitsio/ftgcxd.f | 78 + pkg/tbtables/fitsio/ftgcxi.f | 86 + pkg/tbtables/fitsio/ftgcxj.f | 88 + pkg/tbtables/fitsio/ftgdes.f | 63 + pkg/tbtables/fitsio/ftgerr.f | 173 + pkg/tbtables/fitsio/ftgext.f | 62 + pkg/tbtables/fitsio/ftggpb.f | 31 + pkg/tbtables/fitsio/ftggpd.f | 31 + pkg/tbtables/fitsio/ftggpe.f | 31 + pkg/tbtables/fitsio/ftggpi.f | 31 + pkg/tbtables/fitsio/ftggpj.f | 31 + pkg/tbtables/fitsio/ftghad.f | 30 + pkg/tbtables/fitsio/ftghbn.f | 59 + pkg/tbtables/fitsio/ftghdn.f | 26 + pkg/tbtables/fitsio/ftghpr.f | 28 + pkg/tbtables/fitsio/ftghps.f | 35 + pkg/tbtables/fitsio/ftghsp.f | 40 + pkg/tbtables/fitsio/ftghtb.f | 70 + pkg/tbtables/fitsio/ftgi1b.f | 26 + pkg/tbtables/fitsio/ftgics.f | 47 + pkg/tbtables/fitsio/ftgiou.f | 11 + pkg/tbtables/fitsio/ftgkey.f | 24 + pkg/tbtables/fitsio/ftgknd.f | 79 + pkg/tbtables/fitsio/ftgkne.f | 79 + pkg/tbtables/fitsio/ftgknj.f | 79 + pkg/tbtables/fitsio/ftgknl.f | 73 + pkg/tbtables/fitsio/ftgkns.f | 94 + pkg/tbtables/fitsio/ftgkyd.f | 26 + pkg/tbtables/fitsio/ftgkye.f | 26 + pkg/tbtables/fitsio/ftgkyj.f | 25 + pkg/tbtables/fitsio/ftgkyl.f | 25 + pkg/tbtables/fitsio/ftgkyn.f | 49 + pkg/tbtables/fitsio/ftgkys.f | 68 + pkg/tbtables/fitsio/ftgkyt.f | 53 + pkg/tbtables/fitsio/ftgmsg.f | 7 + pkg/tbtables/fitsio/ftgnst.f | 70 + pkg/tbtables/fitsio/ftgpfb.f | 42 + pkg/tbtables/fitsio/ftgpfd.f | 42 + pkg/tbtables/fitsio/ftgpfe.f | 42 + pkg/tbtables/fitsio/ftgpfi.f | 42 + pkg/tbtables/fitsio/ftgpfj.f | 42 + pkg/tbtables/fitsio/ftgphx.f | 281 + pkg/tbtables/fitsio/ftgprh.f | 14 + pkg/tbtables/fitsio/ftgpvb.f | 37 + pkg/tbtables/fitsio/ftgpvd.f | 37 + pkg/tbtables/fitsio/ftgpve.f | 37 + pkg/tbtables/fitsio/ftgpvi.f | 37 + pkg/tbtables/fitsio/ftgpvj.f | 37 + pkg/tbtables/fitsio/ftgrec.f | 71 + pkg/tbtables/fitsio/ftgsfb.f | 142 + pkg/tbtables/fitsio/ftgsfd.f | 142 + pkg/tbtables/fitsio/ftgsfe.f | 142 + pkg/tbtables/fitsio/ftgsfi.f | 142 + pkg/tbtables/fitsio/ftgsfj.f | 142 + pkg/tbtables/fitsio/ftgsvb.f | 143 + pkg/tbtables/fitsio/ftgsvd.f | 143 + pkg/tbtables/fitsio/ftgsve.f | 143 + pkg/tbtables/fitsio/ftgsvi.f | 143 + pkg/tbtables/fitsio/ftgsvj.f | 143 + pkg/tbtables/fitsio/ftgtbb.f | 64 + pkg/tbtables/fitsio/ftgtbc.f | 81 + pkg/tbtables/fitsio/ftgtbh.f | 12 + pkg/tbtables/fitsio/ftgtbn.f | 123 + pkg/tbtables/fitsio/ftgtbs.f | 71 + pkg/tbtables/fitsio/ftgtcl.f | 64 + pkg/tbtables/fitsio/ftgtcs.f | 53 + pkg/tbtables/fitsio/ftgtdm.f | 99 + pkg/tbtables/fitsio/ftgthd.f | 297 + pkg/tbtables/fitsio/ftgtkn.f | 64 + pkg/tbtables/fitsio/ftgttb.f | 127 + pkg/tbtables/fitsio/fthdef.f | 40 + pkg/tbtables/fitsio/fthpdn.f | 92 + pkg/tbtables/fitsio/fthpup.f | 92 + pkg/tbtables/fitsio/fti1i1.f | 129 + pkg/tbtables/fitsio/fti1i2.f | 140 + pkg/tbtables/fitsio/fti1i4.f | 141 + pkg/tbtables/fitsio/fti1r4.f | 104 + pkg/tbtables/fitsio/fti1r8.f | 104 + pkg/tbtables/fitsio/fti2c.f | 15 + pkg/tbtables/fitsio/fti2i1.f | 156 + pkg/tbtables/fitsio/fti2i2.f | 136 + pkg/tbtables/fitsio/fti2i4.f | 129 + pkg/tbtables/fitsio/fti2r4.f | 92 + pkg/tbtables/fitsio/fti2r8.f | 92 + pkg/tbtables/fitsio/fti4i1.f | 151 + pkg/tbtables/fitsio/fti4i2.f | 157 + pkg/tbtables/fitsio/fti4i4.f | 129 + pkg/tbtables/fitsio/fti4r4.f | 92 + pkg/tbtables/fitsio/fti4r8.f | 92 + pkg/tbtables/fitsio/ftibin.f | 108 + pkg/tbtables/fitsio/ftiblk.f | 189 + pkg/tbtables/fitsio/fticol.f | 154 + pkg/tbtables/fitsio/ftiimg.f | 87 + pkg/tbtables/fitsio/ftikyd.f | 34 + pkg/tbtables/fitsio/ftikye.f | 34 + pkg/tbtables/fitsio/ftikyf.f | 34 + pkg/tbtables/fitsio/ftikyg.f | 34 + pkg/tbtables/fitsio/ftikyj.f | 32 + pkg/tbtables/fitsio/ftikyl.f | 33 + pkg/tbtables/fitsio/ftikys.f | 71 + pkg/tbtables/fitsio/ftinit.f | 43 + pkg/tbtables/fitsio/ftirec.f | 72 + pkg/tbtables/fitsio/ftirow.f | 92 + pkg/tbtables/fitsio/ftitab.f | 108 + pkg/tbtables/fitsio/ftkeyn.f | 70 + pkg/tbtables/fitsio/ftkshf.f | 118 + pkg/tbtables/fitsio/ftl2c.f | 15 + pkg/tbtables/fitsio/ftmahd.f | 73 + pkg/tbtables/fitsio/ftmcom.f | 41 + pkg/tbtables/fitsio/ftmcrd.f | 35 + pkg/tbtables/fitsio/ftmkey.f | 28 + pkg/tbtables/fitsio/ftmkyd.f | 38 + pkg/tbtables/fitsio/ftmkye.f | 34 + pkg/tbtables/fitsio/ftmkyf.f | 34 + pkg/tbtables/fitsio/ftmkyg.f | 34 + pkg/tbtables/fitsio/ftmkyj.f | 32 + pkg/tbtables/fitsio/ftmkyl.f | 33 + pkg/tbtables/fitsio/ftmkys.f | 121 + pkg/tbtables/fitsio/ftmnam.f | 34 + pkg/tbtables/fitsio/ftmodr.f | 46 + pkg/tbtables/fitsio/ftmrec.f | 25 + pkg/tbtables/fitsio/ftmrhd.f | 39 + pkg/tbtables/fitsio/ftnkey.f | 70 + pkg/tbtables/fitsio/ftnulc.f | 78 + pkg/tbtables/fitsio/ftnulm.f | 78 + pkg/tbtables/fitsio/ftopen.f | 58 + pkg/tbtables/fitsio/ftp2db.f | 29 + pkg/tbtables/fitsio/ftp2dd.f | 29 + pkg/tbtables/fitsio/ftp2de.f | 29 + pkg/tbtables/fitsio/ftp2di.f | 29 + pkg/tbtables/fitsio/ftp2dj.f | 29 + pkg/tbtables/fitsio/ftp3db.f | 33 + pkg/tbtables/fitsio/ftp3dd.f | 33 + pkg/tbtables/fitsio/ftp3de.f | 33 + pkg/tbtables/fitsio/ftp3di.f | 33 + pkg/tbtables/fitsio/ftp3dj.f | 33 + pkg/tbtables/fitsio/ftpbit.f | 111 + pkg/tbtables/fitsio/ftpbnh.f | 12 + pkg/tbtables/fitsio/ftpcks.f | 170 + pkg/tbtables/fitsio/ftpclb.f | 318 + pkg/tbtables/fitsio/ftpclc.f | 188 + pkg/tbtables/fitsio/ftpcld.f | 320 + pkg/tbtables/fitsio/ftpcle.f | 317 + pkg/tbtables/fitsio/ftpcli.f | 316 + pkg/tbtables/fitsio/ftpclj.f | 320 + pkg/tbtables/fitsio/ftpcll.f | 162 + pkg/tbtables/fitsio/ftpclm.f | 186 + pkg/tbtables/fitsio/ftpcls.f | 196 + pkg/tbtables/fitsio/ftpclu.f | 279 + pkg/tbtables/fitsio/ftpclx.f | 189 + pkg/tbtables/fitsio/ftpcnb.f | 96 + pkg/tbtables/fitsio/ftpcnd.f | 96 + pkg/tbtables/fitsio/ftpcne.f | 96 + pkg/tbtables/fitsio/ftpcni.f | 96 + pkg/tbtables/fitsio/ftpcnj.f | 96 + pkg/tbtables/fitsio/ftpcom.f | 39 + pkg/tbtables/fitsio/ftpdat.f | 33 + pkg/tbtables/fitsio/ftpdef.f | 156 + pkg/tbtables/fitsio/ftpdes.f | 63 + pkg/tbtables/fitsio/ftpdfl.f | 94 + pkg/tbtables/fitsio/ftpgpb.f | 28 + pkg/tbtables/fitsio/ftpgpd.f | 27 + pkg/tbtables/fitsio/ftpgpe.f | 27 + pkg/tbtables/fitsio/ftpgpi.f | 27 + pkg/tbtables/fitsio/ftpgpj.f | 27 + pkg/tbtables/fitsio/ftphbn.f | 130 + pkg/tbtables/fitsio/ftphis.f | 39 + pkg/tbtables/fitsio/ftphpr.f | 122 + pkg/tbtables/fitsio/ftphtb.f | 110 + pkg/tbtables/fitsio/ftpi1b.f | 26 + pkg/tbtables/fitsio/ftpini.f | 167 + pkg/tbtables/fitsio/ftpkey.f | 28 + pkg/tbtables/fitsio/ftpkls.f | 103 + pkg/tbtables/fitsio/ftpknd.f | 45 + pkg/tbtables/fitsio/ftpkne.f | 45 + pkg/tbtables/fitsio/ftpknf.f | 45 + pkg/tbtables/fitsio/ftpkng.f | 45 + pkg/tbtables/fitsio/ftpknj.f | 43 + pkg/tbtables/fitsio/ftpknl.f | 44 + pkg/tbtables/fitsio/ftpkns.f | 42 + pkg/tbtables/fitsio/ftpkyd.f | 32 + pkg/tbtables/fitsio/ftpkye.f | 26 + pkg/tbtables/fitsio/ftpkyf.f | 26 + pkg/tbtables/fitsio/ftpkyg.f | 26 + pkg/tbtables/fitsio/ftpkyj.f | 24 + pkg/tbtables/fitsio/ftpkyl.f | 25 + pkg/tbtables/fitsio/ftpkys.f | 58 + pkg/tbtables/fitsio/ftpkyt.f | 41 + pkg/tbtables/fitsio/ftplsw.f | 39 + pkg/tbtables/fitsio/ftpmsg.f | 7 + pkg/tbtables/fitsio/ftpnul.f | 58 + pkg/tbtables/fitsio/ftppnb.f | 31 + pkg/tbtables/fitsio/ftppnd.f | 31 + pkg/tbtables/fitsio/ftppne.f | 31 + pkg/tbtables/fitsio/ftppni.f | 31 + pkg/tbtables/fitsio/ftppnj.f | 31 + pkg/tbtables/fitsio/ftpprb.f | 30 + pkg/tbtables/fitsio/ftpprd.f | 29 + pkg/tbtables/fitsio/ftppre.f | 29 + pkg/tbtables/fitsio/ftpprh.f | 12 + pkg/tbtables/fitsio/ftppri.f | 29 + pkg/tbtables/fitsio/ftpprj.f | 29 + pkg/tbtables/fitsio/ftppru.f | 24 + pkg/tbtables/fitsio/ftprec.f | 67 + pkg/tbtables/fitsio/ftprsv.f | 82 + pkg/tbtables/fitsio/ftpscl.f | 66 + pkg/tbtables/fitsio/ftpssb.f | 114 + pkg/tbtables/fitsio/ftpssd.f | 114 + pkg/tbtables/fitsio/ftpsse.f | 114 + pkg/tbtables/fitsio/ftpssi.f | 114 + pkg/tbtables/fitsio/ftpssj.f | 114 + pkg/tbtables/fitsio/ftpsvc.f | 117 + pkg/tbtables/fitsio/ftptbb.f | 64 + pkg/tbtables/fitsio/ftptbh.f | 12 + pkg/tbtables/fitsio/ftptbs.f | 64 + pkg/tbtables/fitsio/ftptdm.f | 60 + pkg/tbtables/fitsio/ftpthp.f | 46 + pkg/tbtables/fitsio/ftr2e.f | 36 + pkg/tbtables/fitsio/ftr2f.f | 34 + pkg/tbtables/fitsio/ftr4i1.f | 154 + pkg/tbtables/fitsio/ftr4i2.f | 161 + pkg/tbtables/fitsio/ftr4i4.f | 165 + pkg/tbtables/fitsio/ftr4r4.f | 93 + pkg/tbtables/fitsio/ftr4r8.f | 93 + pkg/tbtables/fitsio/ftr8i1.f | 154 + pkg/tbtables/fitsio/ftr8i2.f | 159 + pkg/tbtables/fitsio/ftr8i4.f | 160 + pkg/tbtables/fitsio/ftr8r4.f | 93 + pkg/tbtables/fitsio/ftr8r8.f | 93 + pkg/tbtables/fitsio/ftrdef.f | 41 + pkg/tbtables/fitsio/ftrhdu.f | 108 + pkg/tbtables/fitsio/ftrsnm.f | 15 + pkg/tbtables/fitsio/ftrwdn.f | 183 + pkg/tbtables/fitsio/ftrwup.f | 136 + pkg/tbtables/fitsio/fts2c.f | 57 + pkg/tbtables/fitsio/ftsdnn.f | 15 + pkg/tbtables/fitsio/ftsnul.f | 59 + pkg/tbtables/fitsio/ftsrnn.f | 14 + pkg/tbtables/fitsio/fttbit.f | 18 + pkg/tbtables/fitsio/fttdnn.f | 96 + pkg/tbtables/fitsio/fttkey.f | 50 + pkg/tbtables/fitsio/fttkyn.f | 65 + pkg/tbtables/fitsio/fttnul.f | 56 + pkg/tbtables/fitsio/fttrec.f | 44 + pkg/tbtables/fitsio/fttrnn.f | 65 + pkg/tbtables/fitsio/fttscl.f | 65 + pkg/tbtables/fitsio/ftucks.f | 124 + pkg/tbtables/fitsio/ftucrd.f | 28 + pkg/tbtables/fitsio/ftukyd.f | 31 + pkg/tbtables/fitsio/ftukye.f | 31 + pkg/tbtables/fitsio/ftukyf.f | 31 + pkg/tbtables/fitsio/ftukyg.f | 31 + pkg/tbtables/fitsio/ftukyj.f | 29 + pkg/tbtables/fitsio/ftukyl.f | 30 + pkg/tbtables/fitsio/ftukys.f | 30 + pkg/tbtables/fitsio/ftuscc.f | 32 + pkg/tbtables/fitsio/ftuscm.f | 32 + pkg/tbtables/fitsio/ftvcks.f | 83 + pkg/tbtables/fitsio/ftvers.f | 72 + pkg/tbtables/fitsio/ftwend.f | 67 + pkg/tbtables/fitsio/ftwldp.f | 289 + pkg/tbtables/fitsio/ftxiou.f | 37 + pkg/tbtables/fitsio/ftxmsg.f | 47 + pkg/tbtables/fitsio/ftxypx.f | 230 + pkg/tbtables/fitsio/mkpkg | 374 + pkg/tbtables/fitsio/unix/README | 15 + pkg/tbtables/fitsio/unix/ftgcbf.x | 17 + pkg/tbtables/fitsio/unix/ftpcbf.x | 20 + pkg/tbtables/fitsio/unix/mkpkg | 11 + pkg/tbtables/fitsio/vms/README | 15 + pkg/tbtables/fitsio/vms/ftgcbf.x | 20 + pkg/tbtables/fitsio/vms/ftpcbf.x | 18 + pkg/tbtables/fitsio/vms/mkpkg | 11 + pkg/tbtables/fitsio_spp.h | 20 + pkg/tbtables/mkpkg | 250 + pkg/tbtables/selector/generic/mkpkg | 16 + pkg/tbtables/selector/generic/tcsrdaryb.x | 116 + pkg/tbtables/selector/generic/tcsrdaryc.x | 117 + pkg/tbtables/selector/generic/tcsrdaryd.x | 116 + pkg/tbtables/selector/generic/tcsrdaryi.x | 116 + pkg/tbtables/selector/generic/tcsrdaryr.x | 116 + pkg/tbtables/selector/generic/tcsrdarys.x | 116 + pkg/tbtables/selector/mkpkg | 50 + pkg/tbtables/selector/omniread.x | 625 + pkg/tbtables/selector/rdselect.x | 152 + pkg/tbtables/selector/rst.x | 1067 ++ pkg/tbtables/selector/selrows.x | 30 + pkg/tbtables/selector/tbcga.x | 110 + pkg/tbtables/selector/tbcnel.x | 52 + pkg/tbtables/selector/tcs.h | 12 + pkg/tbtables/selector/tcsaddcol.x | 26 + pkg/tbtables/selector/tcsclose.x | 14 + pkg/tbtables/selector/tcscolumn.x | 12 + pkg/tbtables/selector/tcsintinfo.x | 14 + pkg/tbtables/selector/tcslinesize.x | 26 + pkg/tbtables/selector/tcsopen.x | 818 ++ pkg/tbtables/selector/tcsrdary.gx | 140 + pkg/tbtables/selector/tcsshape.x | 24 + pkg/tbtables/selector/tcstotsize.x | 28 + pkg/tbtables/selector/tcstxtinfo.x | 15 + pkg/tbtables/selector/trs.h | 55 + pkg/tbtables/selector/trsclose.x | 25 + pkg/tbtables/selector/trseval.x | 292 + pkg/tbtables/selector/trsgencode.x | 414 + pkg/tbtables/selector/trsopen.com | 15 + pkg/tbtables/selector/trsopen.x | 926 ++ pkg/tbtables/selector/trsopen.y | 601 + pkg/tbtables/selector/trsrows.x | 99 + pkg/tbtables/selector/trstree.x | 211 + pkg/tbtables/selector/trstrim.x | 54 + pkg/tbtables/selector/whatfile.h | 6 + pkg/tbtables/selector/whatfile.x | 63 + pkg/tbtables/tbagt.x | 238 + pkg/tbtables/tbapt.x | 214 + pkg/tbtables/tbbadf.x | 47 + pkg/tbtables/tbbaln.x | 71 + pkg/tbtables/tbbcmt.x | 69 + pkg/tbtables/tbbftp.x | 90 + pkg/tbtables/tbbnll.x | 162 + pkg/tbtables/tbbptf.x | 71 + pkg/tbtables/tbbtyp.x | 52 + pkg/tbtables/tbbwrd.x | 219 + pkg/tbtables/tbcadd.x | 120 + pkg/tbtables/tbcchg.x | 35 + pkg/tbtables/tbcdef.x | 162 + pkg/tbtables/tbcdef1.x | 36 + pkg/tbtables/tbcdes.x | 35 + pkg/tbtables/tbcfmt.x | 39 + pkg/tbtables/tbcfnd.x | 69 + pkg/tbtables/tbcfnd1.x | 25 + pkg/tbtables/tbcftl.x | 23 + pkg/tbtables/tbcgt.x | 272 + pkg/tbtables/tbciga.x | 95 + pkg/tbtables/tbcigi.x | 70 + pkg/tbtables/tbcigt.x | 32 + pkg/tbtables/tbcinf.x | 36 + pkg/tbtables/tbcnam.x | 33 + pkg/tbtables/tbcnit.x | 33 + pkg/tbtables/tbcnum.x | 35 + pkg/tbtables/tbcpt.x | 301 + pkg/tbtables/tbcrcd.x | 211 + pkg/tbtables/tbcscal.x | 75 + pkg/tbtables/tbctpe.x | 103 + pkg/tbtables/tbcwcd.x | 117 + pkg/tbtables/tbdsav.x | 76 + pkg/tbtables/tbegp.x | 123 + pkg/tbtables/tbegt.x | 489 + pkg/tbtables/tbeoff.x | 60 + pkg/tbtables/tbepp.x | 109 + pkg/tbtables/tbept.x | 504 + pkg/tbtables/tbeszt.x | 24 + pkg/tbtables/tbfag.x | 494 + pkg/tbtables/tbfanp.x | 161 + pkg/tbtables/tbfap.x | 557 + pkg/tbtables/tbfcal.x | 113 + pkg/tbtables/tbfchp.x | 27 + pkg/tbtables/tbfckn.x | 69 + pkg/tbtables/tbfclo.x | 28 + pkg/tbtables/tbfdef.x | 198 + pkg/tbtables/tbfdel.x | 31 + pkg/tbtables/tbferr.x | 38 + pkg/tbtables/tbffkw.x | 47 + pkg/tbtables/tbffmt.x | 58 + pkg/tbtables/tbffnd.x | 180 + pkg/tbtables/tbfgcm.x | 50 + pkg/tbtables/tbfgnp.x | 160 + pkg/tbtables/tbfhdl.x | 27 + pkg/tbtables/tbfhg.x | 241 + pkg/tbtables/tbfhp.x | 330 + pkg/tbtables/tbfhp_f.x | 334 + pkg/tbtables/tbfiga.x | 57 + pkg/tbtables/tbfnam.x | 53 + pkg/tbtables/tbfnew.x | 436 + pkg/tbtables/tbfnit.x | 53 + pkg/tbtables/tbfnll.x | 42 + pkg/tbtables/tbfopn.x | 127 + pkg/tbtables/tbfpcm.x | 27 + pkg/tbtables/tbfpnp.x | 146 + pkg/tbtables/tbfpri.x | 181 + pkg/tbtables/tbfptf.x | 95 + pkg/tbtables/tbfrcd.x | 262 + pkg/tbtables/tbfres.x | 58 + pkg/tbtables/tbfrsi.x | 70 + pkg/tbtables/tbfscal.x | 47 + pkg/tbtables/tbfsft.x | 84 + pkg/tbtables/tbfsiz.x | 50 + pkg/tbtables/tbftya.x | 94 + pkg/tbtables/tbftyb.x | 116 + pkg/tbtables/tbfudf.x | 33 + pkg/tbtables/tbfwcd.x | 38 + pkg/tbtables/tbfwer.x | 139 + pkg/tbtables/tbfwsi.x | 33 + pkg/tbtables/tbfxff.c | 795 ++ pkg/tbtables/tbhad.x | 232 + pkg/tbtables/tbhanp.x | 118 + pkg/tbtables/tbhcal.x | 140 + pkg/tbtables/tbhckn.x | 87 + pkg/tbtables/tbhdel.x | 70 + pkg/tbtables/tbhfcm.x | 56 + pkg/tbtables/tbhfkr.x | 58 + pkg/tbtables/tbhfkw.x | 46 + pkg/tbtables/tbhgcm.x | 75 + pkg/tbtables/tbhgnp.x | 115 + pkg/tbtables/tbhgt.x | 244 + pkg/tbtables/tbhisc.x | 35 + pkg/tbtables/tbhkeq.x | 30 + pkg/tbtables/tbhpcm.x | 117 + pkg/tbtables/tbhpnp.x | 179 + pkg/tbtables/tbhpt.x | 268 + pkg/tbtables/tbhrpr.x | 140 + pkg/tbtables/tbhwpr.x | 103 + pkg/tbtables/tblerr.h | 31 + pkg/tbtables/tblfits.h | 25 + pkg/tbtables/tbltext.h | 13 + pkg/tbtables/tbnopen.x | 241 + pkg/tbtables/tbnparse.x | 397 + pkg/tbtables/tbparse.x | 67 + pkg/tbtables/tbpset.x | 109 + pkg/tbtables/tbpsta.x | 175 + pkg/tbtables/tbrchg.x | 25 + pkg/tbtables/tbrcmp.x | 288 + pkg/tbtables/tbrcpy.x | 125 + pkg/tbtables/tbrcsc.x | 173 + pkg/tbtables/tbrdel.x | 77 + pkg/tbtables/tbrgt.x | 267 + pkg/tbtables/tbrnll.x | 67 + pkg/tbtables/tbrpt.x | 248 + pkg/tbtables/tbrsft.x | 51 + pkg/tbtables/tbrswp.x | 138 + pkg/tbtables/tbrudf.x | 66 + pkg/tbtables/tbscol.x | 32 + pkg/tbtables/tbsirow.x | 36 + pkg/tbtables/tbsopn.x | 58 + pkg/tbtables/tbsrow.x | 61 + pkg/tbtables/tbswer.x | 69 + pkg/tbtables/tbswer1.x | 53 + pkg/tbtables/tbtables.h | 200 + pkg/tbtables/tbtacc.x | 40 + pkg/tbtables/tbtbod.x | 28 + pkg/tbtables/tbtchs.x | 176 + pkg/tbtables/tbtclo.x | 91 + pkg/tbtables/tbtcpy.x | 224 + pkg/tbtables/tbtcre.x | 66 + pkg/tbtables/tbtdel.x | 111 + pkg/tbtables/tbtext.x | 100 + pkg/tbtables/tbtflu.x | 34 + pkg/tbtables/tbtfst.x | 45 + pkg/tbtables/tbtnam.x | 51 + pkg/tbtables/tbtopn.x | 280 + pkg/tbtables/tbtopns.x | 298 + pkg/tbtables/tbtren.x | 28 + pkg/tbtables/tbtrsi.x | 74 + pkg/tbtables/tbtscd.x | 58 + pkg/tbtables/tbtscu.x | 63 + pkg/tbtables/tbtsrt.x | 70 + pkg/tbtables/tbttyp.x | 262 + pkg/tbtables/tbtwer.x | 41 + pkg/tbtables/tbtwsi.x | 55 + pkg/tbtables/tbuopn.x | 103 + pkg/tbtables/tbxag.x | 649 + pkg/tbtables/tbxap.x | 807 ++ pkg/tbtables/tbxcg.x | 723 ++ pkg/tbtables/tbxcp.x | 621 + pkg/tbtables/tbxncn.x | 31 + pkg/tbtables/tbxnew.x | 71 + pkg/tbtables/tbxnll.x | 34 + pkg/tbtables/tbxoff.x | 19 + pkg/tbtables/tbxrg.x | 601 + pkg/tbtables/tbxrp.x | 964 ++ pkg/tbtables/tbxscp.x | 77 + pkg/tbtables/tbxsft.x | 76 + pkg/tbtables/tbxsiz.x | 87 + pkg/tbtables/tbxudf.x | 37 + pkg/tbtables/tbxwer.x | 37 + pkg/tbtables/tbxwnc.x | 37 + pkg/tbtables/tbycg.x | 735 ++ pkg/tbtables/tbycp.x | 594 + pkg/tbtables/tbyncn.x | 24 + pkg/tbtables/tbynew.x | 81 + pkg/tbtables/tbynll.x | 39 + pkg/tbtables/tbyoff.x | 20 + pkg/tbtables/tbyrg.x | 569 + pkg/tbtables/tbyrp.x | 455 + pkg/tbtables/tbyscn.x | 86 + pkg/tbtables/tbyscp.x | 91 + pkg/tbtables/tbysft.x | 211 + pkg/tbtables/tbysiz.x | 93 + pkg/tbtables/tbyudf.x | 71 + pkg/tbtables/tbywer.x | 32 + pkg/tbtables/tbywnc.x | 31 + pkg/tbtables/tbzadd.x | 61 + pkg/tbtables/tbzcg.x | 163 + pkg/tbtables/tbzclo.x | 59 + pkg/tbtables/tbzcol.x | 120 + pkg/tbtables/tbzcp.x | 149 + pkg/tbtables/tbzd2t.x | 75 + pkg/tbtables/tbzgt.x | 235 + pkg/tbtables/tbzi2d.x | 41 + pkg/tbtables/tbzi2t.x | 49 + pkg/tbtables/tbzkey.x | 70 + pkg/tbtables/tbzlin.x | 190 + pkg/tbtables/tbzmem.x | 300 + pkg/tbtables/tbznew.x | 50 + pkg/tbtables/tbznll.x | 56 + pkg/tbtables/tbzopn.x | 70 + pkg/tbtables/tbzpt.x | 219 + pkg/tbtables/tbzrds.x | 162 + pkg/tbtables/tbzrdx.x | 135 + pkg/tbtables/tbzsft.x | 146 + pkg/tbtables/tbzsiz.x | 74 + pkg/tbtables/tbzsub.x | 54 + pkg/tbtables/tbzt2t.x | 60 + pkg/tbtables/tbztyp.x | 27 + pkg/tbtables/tbzudf.x | 43 + pkg/tbtables/tbzwer.x | 34 + pkg/tbtables/tbzwrt.x | 257 + pkg/tbtables/underscore.h | 137 + pkg/utilities/README | 3 + pkg/utilities/Revisions | 178 + pkg/utilities/bases.cl | 87 + pkg/utilities/curfit.gx | 216 + pkg/utilities/curfit.h | 19 + pkg/utilities/curfit.par | 12 + pkg/utilities/curfit.x | 404 + pkg/utilities/decod_tablst.x | 104 + pkg/utilities/detab.par | 2 + pkg/utilities/doc/bases.hlp | 43 + pkg/utilities/doc/curfit.hlp | 168 + pkg/utilities/doc/detab.hlp | 28 + pkg/utilities/doc/entab.hlp | 30 + pkg/utilities/doc/lcase.hlp | 32 + pkg/utilities/doc/polyfit.hlp | 91 + pkg/utilities/doc/split.hlp | 59 + pkg/utilities/doc/surfit.hlp | 257 + pkg/utilities/doc/translit.hlp | 49 + pkg/utilities/doc/ucase.hlp | 32 + pkg/utilities/doc/urand.hlp | 41 + pkg/utilities/entab.par | 2 + pkg/utilities/lcase.par | 1 + pkg/utilities/mkpkg | 51 + pkg/utilities/nttools/README | 32 + pkg/utilities/nttools/atools/mkpkg | 10 + pkg/utilities/nttools/atools/taextract.x | 214 + pkg/utilities/nttools/atools/taincr.x | 55 + pkg/utilities/nttools/atools/tainsert.x | 260 + pkg/utilities/nttools/copyone/addslash.x | 32 + pkg/utilities/nttools/copyone/datatype.x | 79 + pkg/utilities/nttools/copyone/filetype.h | 5 + pkg/utilities/nttools/copyone/filetype.x | 28 + pkg/utilities/nttools/copyone/filetype.x.OLD | 61 + pkg/utilities/nttools/copyone/getimghdr.x | 35 + pkg/utilities/nttools/copyone/gettabdat.x | 111 + pkg/utilities/nttools/copyone/gettabhdr.x | 55 + pkg/utilities/nttools/copyone/isdouble.x | 37 + pkg/utilities/nttools/copyone/keypar.x | 109 + pkg/utilities/nttools/copyone/keytab.x | 113 + pkg/utilities/nttools/copyone/mkpkg | 29 + pkg/utilities/nttools/copyone/parkey.x | 71 + pkg/utilities/nttools/copyone/partab.x | 51 + pkg/utilities/nttools/copyone/putimghdr.x | 118 + pkg/utilities/nttools/copyone/puttabdat.x | 106 + pkg/utilities/nttools/copyone/puttabhdr.x | 104 + pkg/utilities/nttools/copyone/tabaccess.x | 19 + pkg/utilities/nttools/copyone/tabhdrtyp.x | 34 + pkg/utilities/nttools/copyone/tabkey.x | 94 + pkg/utilities/nttools/copyone/tabpar.x | 54 + pkg/utilities/nttools/doc/axispar.hlp | 138 + pkg/utilities/nttools/doc/dvpar.hlp | 68 + pkg/utilities/nttools/doc/gtedit.hlp | 116 + pkg/utilities/nttools/doc/gtpar.hlp | 117 + pkg/utilities/nttools/doc/imtab.hlp | 169 + pkg/utilities/nttools/doc/keypar.hlp | 83 + pkg/utilities/nttools/doc/keyselect.hlp | 246 + pkg/utilities/nttools/doc/keytab.hlp | 61 + pkg/utilities/nttools/doc/parkey.hlp | 73 + pkg/utilities/nttools/doc/partab.hlp | 62 + pkg/utilities/nttools/doc/pltpar.hlp | 160 + pkg/utilities/nttools/doc/tabim.hlp | 98 + pkg/utilities/nttools/doc/tabkey.hlp | 68 + pkg/utilities/nttools/doc/tabpar.hlp | 95 + pkg/utilities/nttools/doc/taextract.hlp | 109 + pkg/utilities/nttools/doc/tainsert.hlp | 132 + pkg/utilities/nttools/doc/tcalc.hlp | 153 + pkg/utilities/nttools/doc/tchcol.hlp | 80 + pkg/utilities/nttools/doc/tcheck.hlp | 137 + pkg/utilities/nttools/doc/tchsize.hlp | 158 + pkg/utilities/nttools/doc/tcopy.hlp | 113 + pkg/utilities/nttools/doc/tcreate.hlp | 378 + pkg/utilities/nttools/doc/tdelete.hlp | 74 + pkg/utilities/nttools/doc/tdiffer.hlp | 65 + pkg/utilities/nttools/doc/tdump.hlp | 150 + pkg/utilities/nttools/doc/tedit.hlp | 295 + pkg/utilities/nttools/doc/texpand.hlp | 159 + pkg/utilities/nttools/doc/thedit.hlp | 208 + pkg/utilities/nttools/doc/thistogram.hlp | 152 + pkg/utilities/nttools/doc/thselect.hlp | 90 + pkg/utilities/nttools/doc/tinfo.hlp | 125 + pkg/utilities/nttools/doc/tintegrate.hlp | 97 + pkg/utilities/nttools/doc/tjoin.hlp | 120 + pkg/utilities/nttools/doc/tlcol.hlp | 75 + pkg/utilities/nttools/doc/tlinear.hlp | 127 + pkg/utilities/nttools/doc/tmatch.hlp | 225 + pkg/utilities/nttools/doc/tmerge.hlp | 231 + pkg/utilities/nttools/doc/tprint.hlp | 276 + pkg/utilities/nttools/doc/tproduct.hlp | 48 + pkg/utilities/nttools/doc/tproject.hlp | 79 + pkg/utilities/nttools/doc/tquery.hlp | 115 + pkg/utilities/nttools/doc/tread.hlp | 159 + pkg/utilities/nttools/doc/trebin.hlp | 257 + pkg/utilities/nttools/doc/tselect.hlp | 147 + pkg/utilities/nttools/doc/tsort.hlp | 84 + pkg/utilities/nttools/doc/tstat.hlp | 225 + pkg/utilities/nttools/doc/ttranspose.hlp | 139 + pkg/utilities/nttools/doc/tunits.hlp | 143 + pkg/utilities/nttools/doc/tupar.hlp | 365 + pkg/utilities/nttools/doc/wcspars.hlp | 184 + pkg/utilities/nttools/doc/wlpars.hlp | 440 + pkg/utilities/nttools/gtedit.par | 11 + pkg/utilities/nttools/gtedit/gtdelete.x | 360 + pkg/utilities/nttools/gtedit/gtdodel.x | 41 + pkg/utilities/nttools/gtedit/gtedit.key | 25 + pkg/utilities/nttools/gtedit/gthinfo.x | 69 + pkg/utilities/nttools/gtedit/gtplot.x | 501 + pkg/utilities/nttools/gtedit/gtrdxycol.x | 50 + pkg/utilities/nttools/gtedit/gtupdate.x | 36 + pkg/utilities/nttools/gtedit/gtwrdata.x | 90 + pkg/utilities/nttools/gtedit/gtwrhead.x | 47 + pkg/utilities/nttools/gtedit/mkpkg | 19 + pkg/utilities/nttools/gtedit/t_gtedit.x | 184 + pkg/utilities/nttools/gtpar.par | 27 + pkg/utilities/nttools/imtab.par | 8 + pkg/utilities/nttools/imtab/imtab.h | 4 + pkg/utilities/nttools/imtab/imtab.x | 476 + pkg/utilities/nttools/imtab/itbwcs.x | 129 + pkg/utilities/nttools/imtab/mkpkg | 13 + pkg/utilities/nttools/imtab/tabim.x | 176 + pkg/utilities/nttools/keypar.par | 6 + pkg/utilities/nttools/keyselect.par | 6 + pkg/utilities/nttools/keyselect/expr.x | 193 + pkg/utilities/nttools/keyselect/keyselect.com | 9 + pkg/utilities/nttools/keyselect/keyselect.h | 17 + pkg/utilities/nttools/keyselect/keyselect.x | 122 + pkg/utilities/nttools/keyselect/keyword.x | 253 + pkg/utilities/nttools/keyselect/list.x | 215 + pkg/utilities/nttools/keyselect/mkpkg | 15 + pkg/utilities/nttools/keyselect/tab.x | 353 + pkg/utilities/nttools/keytab.par | 7 + pkg/utilities/nttools/lib/allcols.x | 29 + pkg/utilities/nttools/lib/allrows.x | 29 + pkg/utilities/nttools/lib/compare.com | 7 + pkg/utilities/nttools/lib/compare.x | 258 + pkg/utilities/nttools/lib/ftnexpr.x | 127 + pkg/utilities/nttools/lib/gettabcol.x | 67 + pkg/utilities/nttools/lib/inquotes.x | 121 + pkg/utilities/nttools/lib/invert.x | 55 + pkg/utilities/nttools/lib/mjd.x | 94 + pkg/utilities/nttools/lib/mkpkg | 33 + pkg/utilities/nttools/lib/movenulls.x | 35 + pkg/utilities/nttools/lib/msort.x | 113 + pkg/utilities/nttools/lib/newcolnam.x | 97 + pkg/utilities/nttools/lib/reloperr.h | 3 + pkg/utilities/nttools/lib/reorder.x | 60 + pkg/utilities/nttools/lib/select.x | 99 + pkg/utilities/nttools/lib/tabvar.x | 118 + pkg/utilities/nttools/lib/tbfile.x | 85 + pkg/utilities/nttools/lib/tbleval.x | 159 + pkg/utilities/nttools/lib/tbljoin.x | 168 + pkg/utilities/nttools/lib/tblmerge.x | 162 + pkg/utilities/nttools/lib/tblsearch.x | 104 + pkg/utilities/nttools/lib/tblsort.x | 39 + pkg/utilities/nttools/lib/tblsort1.x | 157 + pkg/utilities/nttools/lib/tblsortm.x | 168 + pkg/utilities/nttools/lib/tblterm.com | 7 + pkg/utilities/nttools/lib/tblterm.x | 256 + pkg/utilities/nttools/lib/tctexp.x | 442 + pkg/utilities/nttools/lib/tldtype.x | 70 + pkg/utilities/nttools/lib/tuopen.x | 197 + pkg/utilities/nttools/lib/unique.x | 64 + pkg/utilities/nttools/mkpkg | 80 + pkg/utilities/nttools/nttools.cl | 60 + pkg/utilities/nttools/nttools.hd | 91 + pkg/utilities/nttools/nttools.hlp | 244 + pkg/utilities/nttools/nttools.men | 61 + pkg/utilities/nttools/nttools.par | 3 + pkg/utilities/nttools/parkey.par | 5 + pkg/utilities/nttools/partab.par | 5 + pkg/utilities/nttools/stxtools/changt.x | 98 + pkg/utilities/nttools/stxtools/checkdim.x | 24 + pkg/utilities/nttools/stxtools/cif.h | 95 + pkg/utilities/nttools/stxtools/cif.x | 806 ++ pkg/utilities/nttools/stxtools/clgnone.x | 37 + pkg/utilities/nttools/stxtools/copyimg.x | 78 + pkg/utilities/nttools/stxtools/doc/wcs.doc | 177 + pkg/utilities/nttools/stxtools/errxit.x | 30 + pkg/utilities/nttools/stxtools/fbuild.x | 97 + pkg/utilities/nttools/stxtools/fparse.x | 170 + pkg/utilities/nttools/stxtools/grmimy.x | 68 + pkg/utilities/nttools/stxtools/isblank.x | 18 + pkg/utilities/nttools/stxtools/lubksb.f | 50 + pkg/utilities/nttools/stxtools/lubksd.f | 53 + pkg/utilities/nttools/stxtools/ludcmd.x | 99 + pkg/utilities/nttools/stxtools/ludcmp.x | 87 + pkg/utilities/nttools/stxtools/mkpkg | 54 + pkg/utilities/nttools/stxtools/od/mkpkg | 15 + pkg/utilities/nttools/stxtools/od/od.h | 32 + pkg/utilities/nttools/stxtools/od/odget.x | 56 + pkg/utilities/nttools/stxtools/od/odmap.x | 250 + pkg/utilities/nttools/stxtools/od/odopep.x | 56 + pkg/utilities/nttools/stxtools/od/odpare.x | 84 + pkg/utilities/nttools/stxtools/od/odput.x | 50 + pkg/utilities/nttools/stxtools/od/odsetn.x | 29 + pkg/utilities/nttools/stxtools/od/odunmp.x | 44 + pkg/utilities/nttools/stxtools/od/odwcsn.x | 39 + pkg/utilities/nttools/stxtools/postexit.x | 52 + pkg/utilities/nttools/stxtools/savgol.x | 140 + pkg/utilities/nttools/stxtools/sbuf.h | 15 + pkg/utilities/nttools/stxtools/sbuf.x | 110 + pkg/utilities/nttools/stxtools/sgcone.x | 94 + pkg/utilities/nttools/stxtools/similar.x | 127 + pkg/utilities/nttools/stxtools/sp_util/mkpkg | 16 + pkg/utilities/nttools/stxtools/sp_util/spchag.x | 64 + pkg/utilities/nttools/stxtools/sp_util/spdise.x | 44 + pkg/utilities/nttools/stxtools/sp_util/spmapt.x | 94 + pkg/utilities/nttools/stxtools/sp_util/sprote.x | 49 + pkg/utilities/nttools/stxtools/sp_util/spstry.x | 24 + pkg/utilities/nttools/stxtools/sp_util/sptras.x | 35 + pkg/utilities/nttools/stxtools/sp_util/spw2ld.x | 50 + pkg/utilities/nttools/stxtools/sp_util/spwcss.x | 90 + pkg/utilities/nttools/stxtools/strjust.x | 31 + pkg/utilities/nttools/stxtools/stxgetcoord.x | 182 + pkg/utilities/nttools/stxtools/template.h | 21 + pkg/utilities/nttools/stxtools/tpbreak.x | 80 + pkg/utilities/nttools/stxtools/tpclose.x | 21 + pkg/utilities/nttools/stxtools/tpcount.x | 134 + pkg/utilities/nttools/stxtools/tpfetch.x | 43 + pkg/utilities/nttools/stxtools/tpgroup.x | 87 + pkg/utilities/nttools/stxtools/tpimtype.x | 116 + pkg/utilities/nttools/stxtools/tpopen.x | 38 + pkg/utilities/nttools/stxtools/tpparse.x | 108 + pkg/utilities/nttools/stxtools/vex.com | 11 + pkg/utilities/nttools/stxtools/vex.h | 107 + pkg/utilities/nttools/stxtools/vexcompile.x | 973 ++ pkg/utilities/nttools/stxtools/vexcompile.y | 616 + pkg/utilities/nttools/stxtools/vexeval.x | 228 + pkg/utilities/nttools/stxtools/vexfree.x | 22 + pkg/utilities/nttools/stxtools/vexfunc.x | 2011 +++ pkg/utilities/nttools/stxtools/vexstack.x | 585 + pkg/utilities/nttools/stxtools/wcslab/mkpkg | 17 + pkg/utilities/nttools/stxtools/wcslab/mkpkg.ori | 18 + pkg/utilities/nttools/stxtools/wcslab/psiescape.h | 80 + pkg/utilities/nttools/stxtools/wcslab/t_wcslab.x | 136 + pkg/utilities/nttools/stxtools/wcslab/wcs_desc.h | 219 + pkg/utilities/nttools/stxtools/wcslab/wcslab.h | 98 + pkg/utilities/nttools/stxtools/wcslab/wcslab.x | 935 ++ pkg/utilities/nttools/stxtools/wcslab/wlgrid.x | 448 + pkg/utilities/nttools/stxtools/wcslab/wllabel.x | 1100 ++ .../nttools/stxtools/wcslab/wllabel.x.ori | 1077 ++ pkg/utilities/nttools/stxtools/wcslab/wlsetup.x | 1000 ++ pkg/utilities/nttools/stxtools/wcslab/wlutil.x | 390 + pkg/utilities/nttools/stxtools/wcslab/wlwcslab.x | 181 + pkg/utilities/nttools/stxtools/word.x | 229 + pkg/utilities/nttools/stxtools/xtwcs.x | 1286 ++ pkg/utilities/nttools/tabim.par | 11 + pkg/utilities/nttools/tabkey.par | 7 + pkg/utilities/nttools/tabpar.par | 7 + pkg/utilities/nttools/tabvar.com | 9 + pkg/utilities/nttools/taextract.par | 10 + pkg/utilities/nttools/tainsert.par | 11 + pkg/utilities/nttools/tcalc.par | 7 + pkg/utilities/nttools/tcalc/mkpkg | 11 + pkg/utilities/nttools/tcalc/tcalc.x | 132 + pkg/utilities/nttools/tchcol.par | 7 + pkg/utilities/nttools/tchcol/mkpkg | 20 + pkg/utilities/nttools/tchcol/tchcol.x | 162 + pkg/utilities/nttools/tcheck.par | 3 + pkg/utilities/nttools/tcheck/cmdsplit.x | 57 + pkg/utilities/nttools/tcheck/mkpkg | 13 + pkg/utilities/nttools/tcheck/tcheck.h | 4 + pkg/utilities/nttools/tcheck/tcheck.x | 91 + pkg/utilities/nttools/tcheck/wrtcheck.x | 61 + pkg/utilities/nttools/tchsize.par | 8 + pkg/utilities/nttools/tchsize/mkpkg | 11 + pkg/utilities/nttools/tchsize/tchsize.x | 173 + pkg/utilities/nttools/tcopy.par | 4 + pkg/utilities/nttools/tcopy/iswholetab.x | 24 + pkg/utilities/nttools/tcopy/mkpkg | 13 + pkg/utilities/nttools/tcopy/tcopy.x | 283 + pkg/utilities/nttools/tcopy/tdelete.x | 126 + pkg/utilities/nttools/tcopy/trename.x | 185 + pkg/utilities/nttools/tcreate.par | 12 + pkg/utilities/nttools/tcreate/gnextl.x | 152 + pkg/utilities/nttools/tcreate/mkpkg | 12 + pkg/utilities/nttools/tcreate/tcreate.x | 958 ++ pkg/utilities/nttools/tdelete.par | 5 + pkg/utilities/nttools/tdiffer.par | 6 + pkg/utilities/nttools/tdiffer/mkpkg | 12 + pkg/utilities/nttools/tdiffer/tbldiff.x | 99 + pkg/utilities/nttools/tdiffer/tdiffer.x | 92 + pkg/utilities/nttools/tdump.par | 8 + pkg/utilities/nttools/tedit.par | 6 + pkg/utilities/nttools/tedit/bell.x | 19 + pkg/utilities/nttools/tedit/command.com | 6 + pkg/utilities/nttools/tedit/command.h | 21 + pkg/utilities/nttools/tedit/command.x | 1458 +++ pkg/utilities/nttools/tedit/display/curses.h | 86 + pkg/utilities/nttools/tedit/display/curses/README | 387 + pkg/utilities/nttools/tedit/display/curses/addch.x | 30 + .../nttools/tedit/display/curses/addstr.x | 157 + .../nttools/tedit/display/curses/bindstruct.x | 35 + pkg/utilities/nttools/tedit/display/curses/box.x | 56 + pkg/utilities/nttools/tedit/display/curses/clear.x | 35 + .../nttools/tedit/display/curses/clearok.x | 21 + .../nttools/tedit/display/curses/clrtobot.x | 56 + .../nttools/tedit/display/curses/clrtoeol.x | 45 + pkg/utilities/nttools/tedit/display/curses/delch.x | 41 + .../nttools/tedit/display/curses/deleteln.x | 41 + .../nttools/tedit/display/curses/delwin.x | 42 + pkg/utilities/nttools/tedit/display/curses/echo.x | 23 + .../nttools/tedit/display/curses/endwin.x | 34 + pkg/utilities/nttools/tedit/display/curses/erase.x | 37 + .../nttools/tedit/display/curses/freescreen.x | 13 + pkg/utilities/nttools/tedit/display/curses/getch.x | 53 + .../nttools/tedit/display/curses/getscreen.x | 48 + .../nttools/tedit/display/curses/getstr.x | 317 + .../nttools/tedit/display/curses/getstruct.x | 27 + pkg/utilities/nttools/tedit/display/curses/getyx.x | 22 + .../nttools/tedit/display/curses/hidewin.x | 40 + pkg/utilities/nttools/tedit/display/curses/inch.x | 49 + .../nttools/tedit/display/curses/initscr.x | 33 + pkg/utilities/nttools/tedit/display/curses/insch.x | 51 + .../nttools/tedit/display/curses/insertln.x | 41 + .../nttools/tedit/display/curses/leaveok.x | 21 + pkg/utilities/nttools/tedit/display/curses/mkpkg | 49 + pkg/utilities/nttools/tedit/display/curses/move.x | 39 + pkg/utilities/nttools/tedit/display/curses/mvwin.x | 63 + .../nttools/tedit/display/curses/mvword.x | 56 + .../nttools/tedit/display/curses/newwin.x | 83 + pkg/utilities/nttools/tedit/display/curses/omkpkg | 65 + .../nttools/tedit/display/curses/putscreen.x | 84 + .../nttools/tedit/display/curses/refresh.x | 42 + .../nttools/tedit/display/curses/savewin.x | 23 + .../nttools/tedit/display/curses/scrollok.x | 21 + .../nttools/tedit/display/curses/showwin.x | 39 + .../nttools/tedit/display/curses/standout.x | 48 + .../nttools/tedit/display/curses/wdimen.x | 45 + .../nttools/tedit/display/curses/window.com | 7 + .../nttools/tedit/display/curses/window.h | 28 + .../nttools/tedit/display/curses/winstat.x | 51 + .../nttools/tedit/display/curses/wslide.x | 91 + pkg/utilities/nttools/tedit/display/forms/README | 115 + .../nttools/tedit/display/forms/fmbegin.x | 20 + .../nttools/tedit/display/forms/fmcheck.x | 98 + pkg/utilities/nttools/tedit/display/forms/fmend.x | 12 + .../nttools/tedit/display/forms/fmgetform.x | 89 + pkg/utilities/nttools/tedit/display/forms/fmhelp.x | 132 + .../nttools/tedit/display/forms/fmmkform.x | 82 + .../nttools/tedit/display/forms/fmprompt.x | 70 + .../nttools/tedit/display/forms/fmredraw.x | 69 + pkg/utilities/nttools/tedit/display/forms/formfn.h | 20 + pkg/utilities/nttools/tedit/display/forms/formfn.x | 278 + .../nttools/tedit/display/forms/forms.com | 5 + pkg/utilities/nttools/tedit/display/forms/linefn.h | 8 + pkg/utilities/nttools/tedit/display/forms/linefn.x | 134 + pkg/utilities/nttools/tedit/display/forms/mkpkg | 19 + .../nttools/tedit/display/forms/promptfn.h | 7 + .../nttools/tedit/display/forms/promptfn.x | 134 + pkg/utilities/nttools/tedit/display/mkpkg | 14 + pkg/utilities/nttools/tedit/display/screen/README | 211 + .../nttools/tedit/display/screen/kbegin.x | 40 + .../nttools/tedit/display/screen/kcompile.x | 148 + .../nttools/tedit/display/screen/kconvert.x | 61 + .../nttools/tedit/display/screen/kdoline.x | 96 + pkg/utilities/nttools/tedit/display/screen/kend.x | 49 + pkg/utilities/nttools/tedit/display/screen/kget.x | 96 + pkg/utilities/nttools/tedit/display/screen/khelp.x | 61 + .../nttools/tedit/display/screen/kpushbk.x | 11 + pkg/utilities/nttools/tedit/display/screen/mkpkg | 32 + .../nttools/tedit/display/screen/psbeep.x | 9 + .../nttools/tedit/display/screen/psbegin.x | 59 + pkg/utilities/nttools/tedit/display/screen/psend.x | 48 + .../nttools/tedit/display/screen/psfill.x | 135 + .../nttools/tedit/display/screen/psheight.x | 12 + .../nttools/tedit/display/screen/psintersect.x | 27 + .../nttools/tedit/display/screen/psscreen.x | 14 + .../nttools/tedit/display/screen/pssendcap.x | 74 + .../nttools/tedit/display/screen/pssetcur.x | 117 + .../nttools/tedit/display/screen/psslide.x | 182 + .../nttools/tedit/display/screen/pssynch.x | 12 + .../nttools/tedit/display/screen/pswidth.x | 12 + .../nttools/tedit/display/screen/pswrite.x | 79 + .../nttools/tedit/display/screen/pswrtcells.x | 114 + .../nttools/tedit/display/screen/screen.com | 18 + pkg/utilities/nttools/tedit/edit.x | 70 + pkg/utilities/nttools/tedit/field.h | 23 + pkg/utilities/nttools/tedit/field.x | 749 ++ pkg/utilities/nttools/tedit/mkpkg | 27 + pkg/utilities/nttools/tedit/paste.h | 6 + pkg/utilities/nttools/tedit/paste.x | 142 + pkg/utilities/nttools/tedit/prompt.x | 225 + pkg/utilities/nttools/tedit/screen.h | 18 + pkg/utilities/nttools/tedit/screen.x | 699 + pkg/utilities/nttools/tedit/substitute.x | 372 + pkg/utilities/nttools/tedit/table.h | 22 + pkg/utilities/nttools/tedit/table.x | 312 + pkg/utilities/nttools/tedit/tedit.key | 23 + pkg/utilities/nttools/tedit/tedit.x | 33 + pkg/utilities/nttools/tedit/tread.x | 31 + pkg/utilities/nttools/tedit/window.com | 8 + pkg/utilities/nttools/tedit/window.x | 246 + pkg/utilities/nttools/texpand.par | 6 + pkg/utilities/nttools/texpand/dbgrules.x | 164 + pkg/utilities/nttools/texpand/lexer.x | 114 + pkg/utilities/nttools/texpand/lexoper.h | 29 + pkg/utilities/nttools/texpand/mkpkg | 21 + pkg/utilities/nttools/texpand/mkrules.x | 48 + pkg/utilities/nttools/texpand/movelem.x | 113 + pkg/utilities/nttools/texpand/movtbrow.x | 43 + pkg/utilities/nttools/texpand/parser.com | 6 + pkg/utilities/nttools/texpand/parser.x | 283 + pkg/utilities/nttools/texpand/pushstack.x | 226 + pkg/utilities/nttools/texpand/span.x | 97 + pkg/utilities/nttools/texpand/texpand.x | 94 + pkg/utilities/nttools/texpand/userules.x | 286 + pkg/utilities/nttools/texpand/x_texpand.x | 3 + pkg/utilities/nttools/thedit.par | 7 + pkg/utilities/nttools/thedit/mkpkg | 13 + pkg/utilities/nttools/thedit/t_thedit.x | 833 ++ pkg/utilities/nttools/thedit/t_thselect.x | 150 + pkg/utilities/nttools/thedit/tkw.x | 405 + pkg/utilities/nttools/thistogram.par | 14 + pkg/utilities/nttools/threed/doc/selectors.hlp | 91 + pkg/utilities/nttools/threed/doc/tiimage.hlp | 108 + pkg/utilities/nttools/threed/doc/titable.hlp | 100 + pkg/utilities/nttools/threed/doc/tscopy.hlp | 94 + pkg/utilities/nttools/threed/doc/tximage.hlp | 85 + pkg/utilities/nttools/threed/doc/txtable.hlp | 89 + pkg/utilities/nttools/threed/mkpkg | 25 + pkg/utilities/nttools/threed/tblerr.h | 27 + pkg/utilities/nttools/threed/tbtables.h | 123 + pkg/utilities/nttools/threed/tiimage.par | 7 + pkg/utilities/nttools/threed/tiimage/design1.txt | 353 + pkg/utilities/nttools/threed/tiimage/generic/mkpkg | 14 + .../nttools/threed/tiimage/generic/tmcp1d.x | 54 + .../nttools/threed/tiimage/generic/tmcp1i.x | 54 + .../nttools/threed/tiimage/generic/tmcp1r.x | 54 + .../nttools/threed/tiimage/generic/tmcp1s.x | 54 + pkg/utilities/nttools/threed/tiimage/list.tex | 789 ++ pkg/utilities/nttools/threed/tiimage/list.toc | 10 + pkg/utilities/nttools/threed/tiimage/loc.txt | 12 + pkg/utilities/nttools/threed/tiimage/mkpkg | 29 + pkg/utilities/nttools/threed/tiimage/tiimage.h | 9 + pkg/utilities/nttools/threed/tiimage/tiimage.x | 147 + pkg/utilities/nttools/threed/tiimage/tmcopy.x | 67 + pkg/utilities/nttools/threed/tiimage/tmcp1.gx | 54 + pkg/utilities/nttools/threed/tiimage/tmhc.x | 57 + pkg/utilities/nttools/threed/tiimage/tmheader.x | 60 + pkg/utilities/nttools/threed/tiimage/tmloop.x | 104 + pkg/utilities/nttools/threed/tiimage/tmmode.x | 108 + pkg/utilities/nttools/threed/tiimage/tmscan.x | 96 + pkg/utilities/nttools/threed/titable.par | 7 + pkg/utilities/nttools/threed/titable/design1.txt | 224 + pkg/utilities/nttools/threed/titable/design2.txt | 244 + pkg/utilities/nttools/threed/titable/generic/mkpkg | 22 + .../nttools/threed/titable/generic/tichb.x | 52 + .../nttools/threed/titable/generic/tichc.x | 54 + .../nttools/threed/titable/generic/tichd.x | 52 + .../nttools/threed/titable/generic/tichi.x | 52 + .../nttools/threed/titable/generic/tichr.x | 52 + .../nttools/threed/titable/generic/tichs.x | 52 + .../nttools/threed/titable/generic/tirowsb.x | 71 + .../nttools/threed/titable/generic/tirowsc.x | 72 + .../nttools/threed/titable/generic/tirowsd.x | 71 + .../nttools/threed/titable/generic/tirowsi.x | 71 + .../nttools/threed/titable/generic/tirowsr.x | 71 + .../nttools/threed/titable/generic/tirowss.x | 71 + pkg/utilities/nttools/threed/titable/help.txt | 117 + pkg/utilities/nttools/threed/titable/list.tex | 979 ++ pkg/utilities/nttools/threed/titable/loc.txt | 11 + pkg/utilities/nttools/threed/titable/mkpkg | 36 + pkg/utilities/nttools/threed/titable/ticc.x | 56 + pkg/utilities/nttools/threed/titable/tich.gx | 74 + pkg/utilities/nttools/threed/titable/ticopy.x | 116 + pkg/utilities/nttools/threed/titable/tiheader.x | 192 + pkg/utilities/nttools/threed/titable/tinew.x | 101 + pkg/utilities/nttools/threed/titable/tinsert.x | 99 + pkg/utilities/nttools/threed/titable/tirows.gx | 98 + pkg/utilities/nttools/threed/titable/tisetc.x | 83 + pkg/utilities/nttools/threed/titable/titable.x | 83 + pkg/utilities/nttools/threed/titable/tiupdate.x | 39 + pkg/utilities/nttools/threed/tscopy.par | 5 + pkg/utilities/nttools/threed/tscopy/mkpkg | 14 + pkg/utilities/nttools/threed/tscopy/tbracket.x | 105 + pkg/utilities/nttools/threed/tscopy/tcpyone.x | 141 + pkg/utilities/nttools/threed/tscopy/tcpyrow.x | 79 + pkg/utilities/nttools/threed/tscopy/tscopy.x | 110 + pkg/utilities/nttools/threed/tximage.par | 5 + pkg/utilities/nttools/threed/tximage/mkpkg | 15 + pkg/utilities/nttools/threed/tximage/txicpy.x | 61 + pkg/utilities/nttools/threed/tximage/txihc.x | 53 + pkg/utilities/nttools/threed/tximage/tximage.x | 117 + pkg/utilities/nttools/threed/tximage/txione.x | 214 + pkg/utilities/nttools/threed/txtable.par | 6 + pkg/utilities/nttools/threed/txtable/generic/mkpkg | 22 + .../nttools/threed/txtable/generic/txtcptb.x | 34 + .../nttools/threed/txtable/generic/txtcptc.x | 35 + .../nttools/threed/txtable/generic/txtcptd.x | 34 + .../nttools/threed/txtable/generic/txtcpti.x | 34 + .../nttools/threed/txtable/generic/txtcptr.x | 34 + .../nttools/threed/txtable/generic/txtcpts.x | 34 + .../nttools/threed/txtable/generic/txthvb.x | 30 + .../nttools/threed/txtable/generic/txthvc.x | 30 + .../nttools/threed/txtable/generic/txthvd.x | 30 + .../nttools/threed/txtable/generic/txthvi.x | 30 + .../nttools/threed/txtable/generic/txthvr.x | 30 + .../nttools/threed/txtable/generic/txthvs.x | 30 + pkg/utilities/nttools/threed/txtable/mkpkg | 34 + pkg/utilities/nttools/threed/txtable/txtable.x | 121 + pkg/utilities/nttools/threed/txtable/txtcpt.gx | 53 + pkg/utilities/nttools/threed/txtable/txtcpy.x | 94 + pkg/utilities/nttools/threed/txtable/txtcpyco.x | 45 + pkg/utilities/nttools/threed/txtable/txtcpysc.x | 34 + pkg/utilities/nttools/threed/txtable/txthc.x | 85 + pkg/utilities/nttools/threed/txtable/txthv.gx | 55 + pkg/utilities/nttools/threed/txtable/txtone.x | 227 + pkg/utilities/nttools/threed/x_threed.x | 5 + pkg/utilities/nttools/thselect.par | 5 + pkg/utilities/nttools/tinfo.par | 15 + pkg/utilities/nttools/tinfo/mkpkg | 12 + pkg/utilities/nttools/tinfo/tinfo.x | 179 + pkg/utilities/nttools/tinfo/tlcol.x | 128 + pkg/utilities/nttools/tintegrate.par | 6 + pkg/utilities/nttools/tintegrate/mkpkg | 11 + pkg/utilities/nttools/tintegrate/tintegrate.x | 155 + pkg/utilities/nttools/tjoin.par | 9 + pkg/utilities/nttools/tjoin/closeiotab.x | 22 + pkg/utilities/nttools/tjoin/dojoin.x | 97 + pkg/utilities/nttools/tjoin/freetol.x | 15 + pkg/utilities/nttools/tjoin/isnumber.x | 35 + pkg/utilities/nttools/tjoin/issame.x | 127 + pkg/utilities/nttools/tjoin/mkjoin.x | 106 + pkg/utilities/nttools/tjoin/mkpkg | 23 + pkg/utilities/nttools/tjoin/openitab.x | 82 + pkg/utilities/nttools/tjoin/openotab.x | 91 + pkg/utilities/nttools/tjoin/readtol.x | 55 + pkg/utilities/nttools/tjoin/removejcol.x | 43 + pkg/utilities/nttools/tjoin/renamecol.x | 109 + pkg/utilities/nttools/tjoin/spptype.x | 29 + pkg/utilities/nttools/tjoin/tjoin.h | 27 + pkg/utilities/nttools/tjoin/tjoin.x | 124 + pkg/utilities/nttools/tlcol.par | 4 + pkg/utilities/nttools/tlinear.par | 10 + pkg/utilities/nttools/tlinear/mkpkg | 11 + pkg/utilities/nttools/tlinear/tlinear.x | 468 + pkg/utilities/nttools/tmatch.par | 18 + pkg/utilities/nttools/tmatch/getmatch.x | 101 + pkg/utilities/nttools/tmatch/getnorm.x | 67 + pkg/utilities/nttools/tmatch/getweight.x | 96 + pkg/utilities/nttools/tmatch/infomatch.x | 219 + pkg/utilities/nttools/tmatch/mkpkg | 20 + pkg/utilities/nttools/tmatch/putmatch.x | 102 + pkg/utilities/nttools/tmatch/rowname.x | 61 + pkg/utilities/nttools/tmatch/setindex.x | 13 + pkg/utilities/nttools/tmatch/sortclose.x | 50 + pkg/utilities/nttools/tmatch/sortdist.x | 50 + pkg/utilities/nttools/tmatch/tmatch.x | 138 + pkg/utilities/nttools/tmerge.par | 9 + pkg/utilities/nttools/tmerge/mkpkg | 20 + pkg/utilities/nttools/tmerge/tmerge.x | 425 + pkg/utilities/nttools/tprint.par | 16 + pkg/utilities/nttools/tprint/mkpkg | 15 + pkg/utilities/nttools/tprint/notes | 40 + pkg/utilities/nttools/tprint/tdump.x | 486 + pkg/utilities/nttools/tprint/tprhtml.x | 592 + pkg/utilities/nttools/tprint/tprint.h | 5 + pkg/utilities/nttools/tprint/tprint.x | 535 + pkg/utilities/nttools/tprint/tprlatex.x | 579 + pkg/utilities/nttools/tprint/tprplain.x | 530 + pkg/utilities/nttools/tproduct.par | 4 + pkg/utilities/nttools/tproduct/mkpkg | 11 + pkg/utilities/nttools/tproduct/tproduct.x | 113 + pkg/utilities/nttools/tproject.par | 5 + pkg/utilities/nttools/tproject/mkpkg | 13 + pkg/utilities/nttools/tproject/nextuniq.x | 39 + pkg/utilities/nttools/tproject/tproject.x | 100 + pkg/utilities/nttools/tproject/wproject.x | 64 + pkg/utilities/nttools/tquery.par | 9 + pkg/utilities/nttools/tquery/doquery.x | 72 + pkg/utilities/nttools/tquery/mkpkg | 13 + pkg/utilities/nttools/tquery/tquery.x | 113 + pkg/utilities/nttools/tquery/wquery.x | 50 + pkg/utilities/nttools/tread.par | 4 + pkg/utilities/nttools/trebin.par | 14 + pkg/utilities/nttools/trebin/mkpkg | 27 + pkg/utilities/nttools/trebin/tnamcls.x | 24 + pkg/utilities/nttools/trebin/tnamgio.x | 79 + pkg/utilities/nttools/trebin/tnaminit.x | 75 + pkg/utilities/nttools/trebin/trebin.h | 5 + pkg/utilities/nttools/trebin/trebin.x | 136 + pkg/utilities/nttools/trebin/tucspl.f | 52 + pkg/utilities/nttools/trebin/tudcol.x | 140 + pkg/utilities/nttools/trebin/tugcol.x | 87 + pkg/utilities/nttools/trebin/tugetput.x | 142 + pkg/utilities/nttools/trebin/tuhunt.f | 103 + pkg/utilities/nttools/trebin/tuiep3.f | 71 + pkg/utilities/nttools/trebin/tuifit.x | 63 + pkg/utilities/nttools/trebin/tuinterp.x | 139 + pkg/utilities/nttools/trebin/tuiset.x | 26 + pkg/utilities/nttools/trebin/tuispl.f | 32 + pkg/utilities/nttools/trebin/tuival.x | 272 + pkg/utilities/nttools/trebin/tutrim.x | 43 + pkg/utilities/nttools/trebin/tuxget.x | 134 + pkg/utilities/nttools/tselect.par | 4 + pkg/utilities/nttools/tselect/mkpkg | 12 + pkg/utilities/nttools/tselect/subset.x | 83 + pkg/utilities/nttools/tselect/tselect.x | 83 + pkg/utilities/nttools/tsort.par | 5 + pkg/utilities/nttools/tsort/mkpkg | 14 + pkg/utilities/nttools/tsort/tblextsort.x | 496 + pkg/utilities/nttools/tsort/tblintsort.x | 48 + pkg/utilities/nttools/tsort/tblmaxrow.x | 39 + pkg/utilities/nttools/tsort/tsort.x | 98 + pkg/utilities/nttools/tstat.par | 21 + pkg/utilities/nttools/tstat/mkpkg | 13 + pkg/utilities/nttools/tstat/thistogram.h | 8 + pkg/utilities/nttools/tstat/thistogram.x | 348 + pkg/utilities/nttools/tstat/thoptions.x | 343 + pkg/utilities/nttools/tstat/tstat.x | 465 + pkg/utilities/nttools/ttranspose.par | 6 + pkg/utilities/nttools/ttranspose/mkpkg | 11 + pkg/utilities/nttools/ttranspose/ttranspose.x | 419 + pkg/utilities/nttools/ttranspose/ttrflip.x | 266 + pkg/utilities/nttools/tunits.par | 8 + pkg/utilities/nttools/tunits/abrev.tab | 62 + pkg/utilities/nttools/tunits/abrev.x | 113 + pkg/utilities/nttools/tunits/convertcol.x | 68 + pkg/utilities/nttools/tunits/factor.x | 125 + pkg/utilities/nttools/tunits/mkpkg | 19 + pkg/utilities/nttools/tunits/parseunits.com | 9 + pkg/utilities/nttools/tunits/parseunits.x | 624 + pkg/utilities/nttools/tunits/parseunits.y | 322 + pkg/utilities/nttools/tunits/tuniterr.x | 24 + pkg/utilities/nttools/tunits/tunits.h | 14 + pkg/utilities/nttools/tunits/tunits.x | 112 + pkg/utilities/nttools/tunits/unhash.x | 212 + pkg/utilities/nttools/tunits/units.tab | 60 + pkg/utilities/nttools/tunits/units.x | 162 + pkg/utilities/nttools/tunits/unstr.x | 381 + pkg/utilities/nttools/tupar.par | 9 + pkg/utilities/nttools/tupar/mkpkg | 12 + pkg/utilities/nttools/tupar/tuinstr.x | 971 ++ pkg/utilities/nttools/tupar/tupar.h | 3 + pkg/utilities/nttools/tupar/tupar.x | 260 + pkg/utilities/nttools/x_nttools.x | 50 + pkg/utilities/nttools/zz.xml | 3427 +++++ pkg/utilities/nttools/zz_bad.xml | 3427 +++++ pkg/utilities/nttools/zz_rewrite.xml | 1191 ++ pkg/utilities/pffctn.x | 17 + pkg/utilities/pfregres.f | 183 + pkg/utilities/polyfit.par | 5 + pkg/utilities/split.par | 6 + pkg/utilities/surfit.par | 18 + pkg/utilities/t_curfit.x | 446 + pkg/utilities/t_detab.x | 30 + pkg/utilities/t_entab.x | 31 + pkg/utilities/t_lcase.x | 42 + pkg/utilities/t_polyfit.x | 244 + pkg/utilities/t_split.x | 108 + pkg/utilities/t_surfit.x | 342 + pkg/utilities/t_translit.x | 294 + pkg/utilities/t_ucase.x | 42 + pkg/utilities/t_urand.x | 47 + pkg/utilities/translit.par | 5 + pkg/utilities/ucase.par | 1 + pkg/utilities/urand.par | 5 + pkg/utilities/utilities.cl | 29 + pkg/utilities/utilities.hd | 26 + pkg/utilities/utilities.men | 13 + pkg/utilities/utilities.par | 1 + pkg/utilities/x_utilities.x | 14 + pkg/vocl/Notes.ecl | 1098 ++ pkg/vocl/Notes.samp | 241 + pkg/vocl/README | 17 + pkg/vocl/Revisions | 31 + pkg/vocl/TODO | 13 + pkg/vocl/_samp.cmds | 101 + pkg/vocl/_samp.funcs | 25 + pkg/vocl/binop.c | 826 ++ pkg/vocl/bkg.c | 649 + pkg/vocl/builtin.c | 2596 ++++ pkg/vocl/builtin_vo.c | 194 + pkg/vocl/cl.csh | 157 + pkg/vocl/cl.csh.SSOL | 94 + pkg/vocl/cl.par | 56 + pkg/vocl/clmodes.h | 80 + pkg/vocl/clprintf.c | 205 + pkg/vocl/clsamp.h | 100 + pkg/vocl/clsystem.c | 67 + pkg/vocl/compile.c | 253 + pkg/vocl/config.h | 76 + pkg/vocl/construct.h | 44 + pkg/vocl/debug.c | 486 + pkg/vocl/decl.c | 850 ++ pkg/vocl/doc/ecl.hlp | 1099 ++ pkg/vocl/doc/pset.sys | 222 + pkg/vocl/ecl_install.csh | 414 + pkg/vocl/edcap.c | 390 + pkg/vocl/eparam.c | 2156 ++++ pkg/vocl/eparam.h | 108 + pkg/vocl/errs.c | 401 + pkg/vocl/errs.h | 72 + pkg/vocl/errtest/errif.cl | 24 + pkg/vocl/errtest/errtest.cl | 25 + pkg/vocl/errtest/errtest.hd | 9 + pkg/vocl/errtest/errtest.men | 14 + pkg/vocl/errtest/errtest.par | 3 + pkg/vocl/errtest/errtype.cl | 74 + pkg/vocl/errtest/mkpkg | 9 + pkg/vocl/errtest/nest0.cl | 14 + pkg/vocl/errtest/nested.cl | 12 + pkg/vocl/errtest/printvals.cl | 20 + pkg/vocl/errtest/recur0.cl | 13 + pkg/vocl/errtest/recursion.cl | 13 + pkg/vocl/errtest/sfpe.cl | 6 + pkg/vocl/errtest/spperrs.x | 25 + pkg/vocl/errtest/test_iferr.cl | 33 + pkg/vocl/errtest/zztest.cl | 24 + pkg/vocl/exec.c | 1400 ++ pkg/vocl/globals.c | 117 + pkg/vocl/gquery.c | 200 + pkg/vocl/gram.c | 1443 +++ pkg/vocl/grammar.h | 61 + pkg/vocl/grammar.l | 198 + pkg/vocl/grammar.y | 2108 +++ pkg/vocl/history.c | 1279 ++ pkg/vocl/lex.com | 12 + pkg/vocl/lex.sed | 4 + pkg/vocl/lexicon.c | 704 + pkg/vocl/lexyy.c | 900 ++ pkg/vocl/lists.c | 121 + pkg/vocl/login.cl | 112 + pkg/vocl/logout.cl | 5 + pkg/vocl/main.c | 849 ++ pkg/vocl/mem.h | 109 + pkg/vocl/mkdist | 87 + pkg/vocl/mkpkg | 226 + pkg/vocl/modes.c | 1261 ++ pkg/vocl/multop.c | 213 + pkg/vocl/opcodes.c | 1400 ++ pkg/vocl/opcodes.h | 127 + pkg/vocl/operand.c | 411 + pkg/vocl/operand.h | 264 + pkg/vocl/param.c | 1397 ++ pkg/vocl/param.h | 220 + pkg/vocl/pfiles.c | 1968 +++ pkg/vocl/prcache.c | 708 + pkg/vocl/proto.h | 447 + pkg/vocl/samp.c | 667 + pkg/vocl/sampCmd.c | 973 ++ pkg/vocl/sampDecl.h | 438 + pkg/vocl/sampFuncs.c | 1186 ++ pkg/vocl/sampHandlers.c | 515 + pkg/vocl/scan.c | 342 + pkg/vocl/stack.c | 213 + pkg/vocl/tags | 481 + pkg/vocl/task.c | 569 + pkg/vocl/task.h | 226 + pkg/vocl/unop.c | 419 + pkg/vocl/uparm/history.cl | 22 + pkg/vocl/uparm/usrtest.par | 2 + pkg/vocl/vocl.x | 32 + pkg/vocl/voclient.c | 1754 +++ pkg/vocl/voclient.h | 131 + pkg/vocl/y.output | 7034 ++++++++++ pkg/vocl/ytab.c | 4644 +++++++ pkg/vocl/ytab.h | 171 + pkg/xtools/README | 12 + pkg/xtools/Revisions | 1008 ++ pkg/xtools/catquery/cq.h | 100 + pkg/xtools/catquery/cqdb.x | 442 + pkg/xtools/catquery/cqdef.h | 133 + pkg/xtools/catquery/cqdtype.x | 53 + pkg/xtools/catquery/cqget.x | 225 + pkg/xtools/catquery/cqgfields.x | 483 + pkg/xtools/catquery/cqgqpars.x | 99 + pkg/xtools/catquery/cqgrecords.x | 83 + pkg/xtools/catquery/cqiminfo.x | 220 + pkg/xtools/catquery/cqimquery.x | 931 ++ pkg/xtools/catquery/cqistat.x | 161 + pkg/xtools/catquery/cqlocate.x | 40 + pkg/xtools/catquery/cqmap.x | 112 + pkg/xtools/catquery/cqnqpars.x | 18 + pkg/xtools/catquery/cqquery.x | 998 ++ pkg/xtools/catquery/cqrinfo.x | 390 + pkg/xtools/catquery/cqrstat.x | 171 + pkg/xtools/catquery/cqsetcat.x | 293 + pkg/xtools/catquery/cqsqpars.x | 135 + pkg/xtools/catquery/cqstat.x | 74 + pkg/xtools/catquery/cqwrdstr.x | 56 + pkg/xtools/catquery/doc/README | 322 + pkg/xtools/catquery/doc/catalogs.hlp | 233 + pkg/xtools/catquery/doc/catquery.hd | 56 + pkg/xtools/catquery/doc/catquery.hlp | 322 + pkg/xtools/catquery/doc/catquery.men | 28 + pkg/xtools/catquery/doc/ccsystems.hlp | 134 + pkg/xtools/catquery/doc/cqfimquery.hlp | 39 + pkg/xtools/catquery/doc/cqfinfo.hlp | 85 + pkg/xtools/catquery/doc/cqfinfon.hlp | 79 + pkg/xtools/catquery/doc/cqfquery.hlp | 78 + pkg/xtools/catquery/doc/cqget.hlp | 130 + pkg/xtools/catquery/doc/cqgnrecord.hlp | 61 + pkg/xtools/catquery/doc/cqgqpar.hlp | 72 + pkg/xtools/catquery/doc/cqgqparn.hlp | 73 + pkg/xtools/catquery/doc/cqgrecord.hlp | 46 + pkg/xtools/catquery/doc/cqgvalc.hlp | 42 + pkg/xtools/catquery/doc/cqgvald.hlp | 40 + pkg/xtools/catquery/doc/cqgvali.hlp | 40 + pkg/xtools/catquery/doc/cqgvall.hlp | 40 + pkg/xtools/catquery/doc/cqgvalr.hlp | 40 + pkg/xtools/catquery/doc/cqgvals.hlp | 41 + pkg/xtools/catquery/doc/cqhinfo.hlp | 39 + pkg/xtools/catquery/doc/cqhinfon.hlp | 47 + pkg/xtools/catquery/doc/cqimclose.hlp | 24 + pkg/xtools/catquery/doc/cqimquery.hlp | 44 + pkg/xtools/catquery/doc/cqistati.hlp | 49 + pkg/xtools/catquery/doc/cqistats.hlp | 56 + pkg/xtools/catquery/doc/cqistatt.hlp | 55 + pkg/xtools/catquery/doc/cqkinfo.hlp | 65 + pkg/xtools/catquery/doc/cqkinfon.hlp | 73 + pkg/xtools/catquery/doc/cqlocate.hlp | 35 + pkg/xtools/catquery/doc/cqlocaten.hlp | 47 + pkg/xtools/catquery/doc/cqmap.hlp | 33 + pkg/xtools/catquery/doc/cqnqpars.hlp | 32 + pkg/xtools/catquery/doc/cqquery.hlp | 35 + pkg/xtools/catquery/doc/cqrclose.hlp | 24 + pkg/xtools/catquery/doc/cqrstati.hlp | 53 + pkg/xtools/catquery/doc/cqrstats.hlp | 54 + pkg/xtools/catquery/doc/cqrstatt.hlp | 56 + pkg/xtools/catquery/doc/cqsetcat.hlp | 35 + pkg/xtools/catquery/doc/cqsetcatn.hlp | 35 + pkg/xtools/catquery/doc/cqsqpar.hlp | 39 + pkg/xtools/catquery/doc/cqsqparn.hlp | 39 + pkg/xtools/catquery/doc/cqstati.hlp | 61 + pkg/xtools/catquery/doc/cqstats.hlp | 48 + pkg/xtools/catquery/doc/cqstatt.hlp | 45 + pkg/xtools/catquery/doc/cqunmap.hlp | 26 + pkg/xtools/catquery/doc/cqwinfo.hlp | 65 + pkg/xtools/catquery/doc/cqwinfon.hlp | 75 + pkg/xtools/catquery/doc/surveys.hlp | 197 + pkg/xtools/catquery/mkpkg | 32 + pkg/xtools/center1d.h | 6 + pkg/xtools/center1d.x | 272 + pkg/xtools/clgcurfit.x | 29 + pkg/xtools/clginterp.x | 27 + pkg/xtools/clgsec.x | 57 + pkg/xtools/cogetr.h | 16 + pkg/xtools/cogetr.x | 162 + pkg/xtools/doc/Notes | 42 + pkg/xtools/doc/center1d.hlp | 147 + pkg/xtools/doc/cogetr.hlp | 88 + pkg/xtools/doc/extrema.hlp | 27 + pkg/xtools/doc/inlfit.hlp | 259 + pkg/xtools/doc/peaks.hlp | 28 + pkg/xtools/doc/ranges.hlp | 105 + pkg/xtools/doc/xtextns.hlp | 115 + pkg/xtools/doc/xtmaskname.hlp | 85 + pkg/xtools/doc/xtools.hd | 45 + pkg/xtools/doc/xtools.men | 23 + pkg/xtools/doc/xtpmmap.hlp | 144 + pkg/xtools/doc/xtsums.hlp | 83 + pkg/xtools/dttext.x | 698 + pkg/xtools/extrema.x | 70 + pkg/xtools/fixpix/mkpkg | 25 + pkg/xtools/fixpix/setfp.x | 72 + pkg/xtools/fixpix/xtfixpix.h | 24 + pkg/xtools/fixpix/xtfixpix.x | 270 + pkg/xtools/fixpix/xtfp.gx | 275 + pkg/xtools/fixpix/xtfp.x | 1271 ++ pkg/xtools/fixpix/xtpmmap.x | 693 + pkg/xtools/fixpix/ytfixpix.x | 281 + pkg/xtools/fixpix/ytpmmap.x | 961 ++ pkg/xtools/getdatatype.x | 57 + pkg/xtools/gstrdetab.x | 32 + pkg/xtools/gstrentab.x | 40 + pkg/xtools/gstrsettab.x | 23 + pkg/xtools/gtools/Revisions | 172 + pkg/xtools/gtools/gtascale.x | 100 + pkg/xtools/gtools/gtcolon.x | 754 ++ pkg/xtools/gtools/gtcopy.x | 85 + pkg/xtools/gtools/gtctran.x | 34 + pkg/xtools/gtools/gtcur.x | 21 + pkg/xtools/gtools/gtcur1.x | 38 + pkg/xtools/gtools/gtfree.x | 26 + pkg/xtools/gtools/gtget.x | 210 + pkg/xtools/gtools/gtgui.x | 160 + pkg/xtools/gtools/gthelp.x | 12 + pkg/xtools/gtools/gtinit.x | 164 + pkg/xtools/gtools/gtlabax.x | 139 + pkg/xtools/gtools/gtools.h | 168 + pkg/xtools/gtools/gtools.hd | 3 + pkg/xtools/gtools/gtools.hlp | 91 + pkg/xtools/gtools/gtplot.x | 82 + pkg/xtools/gtools/gtreset.x | 83 + pkg/xtools/gtools/gtset.x | 224 + pkg/xtools/gtools/gtswind.x | 65 + pkg/xtools/gtools/gtvplot.x | 51 + pkg/xtools/gtools/gtwindow.x | 180 + pkg/xtools/gtools/mkpkg | 27 + pkg/xtools/icfit/Revisions | 405 + pkg/xtools/icfit/icclean.gx | 92 + pkg/xtools/icfit/iccleand.x | 92 + pkg/xtools/icfit/iccleanr.x | 92 + pkg/xtools/icfit/icdeviant.gx | 134 + pkg/xtools/icfit/icdeviantd.x | 134 + pkg/xtools/icfit/icdeviantr.x | 134 + pkg/xtools/icfit/icdosetup.gx | 121 + pkg/xtools/icfit/icdosetupd.x | 121 + pkg/xtools/icfit/icdosetupr.x | 121 + pkg/xtools/icfit/icerrors.gx | 24 + pkg/xtools/icfit/icerrorsd.x | 24 + pkg/xtools/icfit/icerrorsr.x | 24 + pkg/xtools/icfit/icferrors.gx | 141 + pkg/xtools/icfit/icferrorsd.x | 141 + pkg/xtools/icfit/icferrorsr.x | 141 + pkg/xtools/icfit/icfit.gx | 99 + pkg/xtools/icfit/icfit.h | 50 + pkg/xtools/icfit/icfit.hlp | 229 + pkg/xtools/icfit/icfitd.x | 99 + pkg/xtools/icfit/icfitr.x | 99 + pkg/xtools/icfit/icfshow.x | 62 + pkg/xtools/icfit/icfvshow.gx | 164 + pkg/xtools/icfit/icfvshowd.x | 164 + pkg/xtools/icfit/icfvshowr.x | 164 + pkg/xtools/icfit/icgadd.gx | 50 + pkg/xtools/icfit/icgaddd.x | 50 + pkg/xtools/icfit/icgaddr.x | 50 + pkg/xtools/icfit/icgaxes.gx | 103 + pkg/xtools/icfit/icgaxesd.x | 103 + pkg/xtools/icfit/icgaxesr.x | 103 + pkg/xtools/icfit/icgcolon.gx | 218 + pkg/xtools/icfit/icgcolond.x | 218 + pkg/xtools/icfit/icgcolonr.x | 218 + pkg/xtools/icfit/icgdelete.gx | 89 + pkg/xtools/icfit/icgdeleted.x | 89 + pkg/xtools/icfit/icgdeleter.x | 89 + pkg/xtools/icfit/icgfit.gx | 544 + pkg/xtools/icfit/icgfitd.x | 544 + pkg/xtools/icfit/icgfitr.x | 544 + pkg/xtools/icfit/icggraph.gx | 226 + pkg/xtools/icfit/icggraphd.x | 226 + pkg/xtools/icfit/icggraphr.x | 226 + pkg/xtools/icfit/icgnearest.gx | 74 + pkg/xtools/icfit/icgnearestd.x | 74 + pkg/xtools/icfit/icgnearestr.x | 74 + pkg/xtools/icfit/icgparams.gx | 118 + pkg/xtools/icfit/icgparamsd.x | 118 + pkg/xtools/icfit/icgparamsr.x | 118 + pkg/xtools/icfit/icgsample.gx | 226 + pkg/xtools/icfit/icgsampled.x | 226 + pkg/xtools/icfit/icgsampler.x | 226 + pkg/xtools/icfit/icguaxes.gx | 18 + pkg/xtools/icfit/icguaxesd.x | 18 + pkg/xtools/icfit/icguaxesr.x | 18 + pkg/xtools/icfit/icgui.x | 138 + pkg/xtools/icfit/icguishow.gx | 86 + pkg/xtools/icfit/icguishowd.x | 86 + pkg/xtools/icfit/icguishowr.x | 86 + pkg/xtools/icfit/icgundelete.gx | 93 + pkg/xtools/icfit/icgundeleted.x | 93 + pkg/xtools/icfit/icgundeleter.x | 93 + pkg/xtools/icfit/icguser.x | 19 + pkg/xtools/icfit/iclist.gx | 45 + pkg/xtools/icfit/iclistd.x | 45 + pkg/xtools/icfit/iclistr.x | 45 + pkg/xtools/icfit/icparams.x | 388 + pkg/xtools/icfit/icreject.gx | 57 + pkg/xtools/icfit/icrejectd.x | 57 + pkg/xtools/icfit/icrejectr.x | 57 + pkg/xtools/icfit/icshow.x | 21 + pkg/xtools/icfit/icvshow.gx | 48 + pkg/xtools/icfit/icvshowd.x | 48 + pkg/xtools/icfit/icvshowr.x | 48 + pkg/xtools/icfit/mkpkg | 85 + pkg/xtools/icfit/names.h | 21 + pkg/xtools/imtools.x | 147 + pkg/xtools/inlfit/README | 165 + pkg/xtools/inlfit/incopy.gx | 126 + pkg/xtools/inlfit/incopyd.x | 126 + pkg/xtools/inlfit/incopyr.x | 126 + pkg/xtools/inlfit/indeviant.gx | 121 + pkg/xtools/inlfit/indeviantd.x | 121 + pkg/xtools/inlfit/indeviantr.x | 121 + pkg/xtools/inlfit/indump.gx | 233 + pkg/xtools/inlfit/indumpd.x | 233 + pkg/xtools/inlfit/indumpr.x | 233 + pkg/xtools/inlfit/inerrors.gx | 66 + pkg/xtools/inlfit/inerrorsd.x | 66 + pkg/xtools/inlfit/inerrorsr.x | 66 + pkg/xtools/inlfit/infit.gx | 99 + pkg/xtools/inlfit/infitd.x | 99 + pkg/xtools/inlfit/infitr.x | 99 + pkg/xtools/inlfit/infree.gx | 52 + pkg/xtools/inlfit/infreed.x | 52 + pkg/xtools/inlfit/infreer.x | 52 + pkg/xtools/inlfit/ingaxes.gx | 105 + pkg/xtools/inlfit/ingaxesd.x | 105 + pkg/xtools/inlfit/ingaxesr.x | 105 + pkg/xtools/inlfit/ingcolon.gx | 362 + pkg/xtools/inlfit/ingcolond.x | 362 + pkg/xtools/inlfit/ingcolonr.x | 362 + pkg/xtools/inlfit/ingdata.gx | 86 + pkg/xtools/inlfit/ingdatad.x | 86 + pkg/xtools/inlfit/ingdatar.x | 86 + pkg/xtools/inlfit/ingdefkey.x | 182 + pkg/xtools/inlfit/ingdelete.gx | 87 + pkg/xtools/inlfit/ingdeleted.x | 87 + pkg/xtools/inlfit/ingdeleter.x | 87 + pkg/xtools/inlfit/ingerrors.gx | 139 + pkg/xtools/inlfit/ingerrorsd.x | 139 + pkg/xtools/inlfit/ingerrorsr.x | 139 + pkg/xtools/inlfit/inget.gx | 220 + pkg/xtools/inlfit/inget.x | 242 + pkg/xtools/inlfit/ingfit.gx | 204 + pkg/xtools/inlfit/ingfitd.x | 204 + pkg/xtools/inlfit/ingfitr.x | 204 + pkg/xtools/inlfit/inggetlabel.x | 78 + pkg/xtools/inlfit/inggraph.gx | 240 + pkg/xtools/inlfit/inggraphd.x | 240 + pkg/xtools/inlfit/inggraphr.x | 240 + pkg/xtools/inlfit/ingnearest.gx | 81 + pkg/xtools/inlfit/ingnearestd.x | 81 + pkg/xtools/inlfit/ingnearestr.x | 81 + pkg/xtools/inlfit/ingparams.gx | 120 + pkg/xtools/inlfit/ingparamsd.x | 120 + pkg/xtools/inlfit/ingparamsr.x | 120 + pkg/xtools/inlfit/ingresults.gx | 85 + pkg/xtools/inlfit/ingresultsd.x | 85 + pkg/xtools/inlfit/ingresultsr.x | 85 + pkg/xtools/inlfit/ingshow.gx | 40 + pkg/xtools/inlfit/ingshowd.x | 40 + pkg/xtools/inlfit/ingshowr.x | 40 + pkg/xtools/inlfit/ingtitle.x | 49 + pkg/xtools/inlfit/inguaxes.gx | 47 + pkg/xtools/inlfit/inguaxesd.x | 47 + pkg/xtools/inlfit/inguaxesr.x | 47 + pkg/xtools/inlfit/ingucolon.gx | 19 + pkg/xtools/inlfit/ingucolond.x | 19 + pkg/xtools/inlfit/ingucolonr.x | 19 + pkg/xtools/inlfit/ingufit.x | 17 + pkg/xtools/inlfit/ingundelete.gx | 92 + pkg/xtools/inlfit/ingundeleted.x | 92 + pkg/xtools/inlfit/ingundeleter.x | 92 + pkg/xtools/inlfit/ingvars.gx | 55 + pkg/xtools/inlfit/ingvarsd.x | 55 + pkg/xtools/inlfit/ingvarsr.x | 55 + pkg/xtools/inlfit/ingvshow.gx | 34 + pkg/xtools/inlfit/ingvshowd.x | 34 + pkg/xtools/inlfit/ingvshowr.x | 34 + pkg/xtools/inlfit/ininit.gx | 172 + pkg/xtools/inlfit/ininitd.x | 172 + pkg/xtools/inlfit/ininitr.x | 172 + pkg/xtools/inlfit/inlfitdef.h | 148 + pkg/xtools/inlfit/inlgfit.key | 77 + pkg/xtools/inlfit/inlimit.gx | 51 + pkg/xtools/inlfit/inlimitd.x | 51 + pkg/xtools/inlfit/inlimitr.x | 51 + pkg/xtools/inlfit/inlstrext.x | 47 + pkg/xtools/inlfit/inlstrwrd.x | 51 + pkg/xtools/inlfit/innlinit.gx | 28 + pkg/xtools/inlfit/innlinitd.x | 28 + pkg/xtools/inlfit/innlinitr.x | 28 + pkg/xtools/inlfit/input.gx | 188 + pkg/xtools/inlfit/input.x | 211 + pkg/xtools/inlfit/inrefit.gx | 67 + pkg/xtools/inlfit/inrefitd.x | 67 + pkg/xtools/inlfit/inrefitr.x | 67 + pkg/xtools/inlfit/inreject.gx | 72 + pkg/xtools/inlfit/inrejectd.x | 72 + pkg/xtools/inlfit/inrejectr.x | 72 + pkg/xtools/inlfit/inrms.gx | 31 + pkg/xtools/inlfit/inrmsd.x | 31 + pkg/xtools/inlfit/inrmsr.x | 31 + pkg/xtools/inlfit/mkpkg | 122 + pkg/xtools/intrp.f | 292 + pkg/xtools/isdir.x | 69 + pkg/xtools/mef/Notes | 26 + pkg/xtools/mef/mefappfile.x | 109 + pkg/xtools/mef/mefclose.x | 17 + pkg/xtools/mef/mefcpextn.x | 46 + pkg/xtools/mef/mefdummyh.x | 84 + pkg/xtools/mef/mefencode.x | 530 + pkg/xtools/mef/mefget.x | 183 + pkg/xtools/mef/mefgnbc.x | 55 + pkg/xtools/mef/mefgval.x | 182 + pkg/xtools/mef/mefkfind.x | 75 + pkg/xtools/mef/mefksection.x | 174 + pkg/xtools/mef/mefldhdr.x | 118 + pkg/xtools/mef/mefopen.x | 93 + pkg/xtools/mef/mefrdhdr.x | 397 + pkg/xtools/mef/mefrdhdr.x_save | 529 + pkg/xtools/mef/mefsetpl.x | 203 + pkg/xtools/mef/mefwrhdr.x | 212 + pkg/xtools/mef/mefwrhdr.x_save | 185 + pkg/xtools/mef/mefwrpl.x | 213 + pkg/xtools/mef/mkpkg | 26 + pkg/xtools/mkpkg | 80 + pkg/xtools/numrecipes.x | 689 + pkg/xtools/obsdb.x | 568 + pkg/xtools/peaks.x | 70 + pkg/xtools/ranges.par | 4 + pkg/xtools/ranges.x | 245 + pkg/xtools/ranges/Revisions | 59 + pkg/xtools/ranges/mkpkg | 49 + pkg/xtools/ranges/rgbin.gx | 75 + pkg/xtools/ranges/rgbind.x | 75 + pkg/xtools/ranges/rgbinr.x | 75 + pkg/xtools/ranges/rgdump.x | 28 + pkg/xtools/ranges/rgencode.x | 52 + pkg/xtools/ranges/rgexclude.gx | 56 + pkg/xtools/ranges/rgexcluded.x | 56 + pkg/xtools/ranges/rgexcluder.x | 56 + pkg/xtools/ranges/rgfree.x | 14 + pkg/xtools/ranges/rggxmark.gx | 52 + pkg/xtools/ranges/rggxmarkd.x | 52 + pkg/xtools/ranges/rggxmarkr.x | 52 + pkg/xtools/ranges/rgindices.x | 81 + pkg/xtools/ranges/rginrange.x | 29 + pkg/xtools/ranges/rgintersect.x | 58 + pkg/xtools/ranges/rginverse.x | 34 + pkg/xtools/ranges/rgmerge.x | 38 + pkg/xtools/ranges/rgnext.x | 32 + pkg/xtools/ranges/rgorder.x | 43 + pkg/xtools/ranges/rgpack.gx | 37 + pkg/xtools/ranges/rgpackd.x | 37 + pkg/xtools/ranges/rgpackr.x | 37 + pkg/xtools/ranges/rgranges.x | 136 + pkg/xtools/ranges/rgunion.x | 48 + pkg/xtools/ranges/rgunpack.gx | 37 + pkg/xtools/ranges/rgunpackd.x | 37 + pkg/xtools/ranges/rgunpackr.x | 37 + pkg/xtools/ranges/rgwindow.x | 43 + pkg/xtools/ranges/rgwtbin.gx | 112 + pkg/xtools/ranges/rgwtbind.x | 112 + pkg/xtools/ranges/rgwtbinr.x | 112 + pkg/xtools/ranges/rgxranges.gx | 162 + pkg/xtools/ranges/rgxranges1.gx | 146 + pkg/xtools/ranges/rgxrangesd.x | 162 + pkg/xtools/ranges/rgxrangesr.x | 162 + pkg/xtools/rmmed.x | 446 + pkg/xtools/rmsorted.x | 183 + pkg/xtools/rmturlach.x | 417 + pkg/xtools/rngranges.x | 384 + pkg/xtools/rngranges.xBAK | 384 + pkg/xtools/skywcs/doc/README | 301 + pkg/xtools/skywcs/doc/ccsystems.hlp | 134 + pkg/xtools/skywcs/doc/skclose.hlp | 23 + pkg/xtools/skywcs/doc/skcopy.hlp | 24 + pkg/xtools/skywcs/doc/skdecim.hlp | 56 + pkg/xtools/skywcs/doc/skdecwcs.hlp | 62 + pkg/xtools/skywcs/doc/skdecwstr.hlp | 46 + pkg/xtools/skywcs/doc/skenwcs.hlp | 32 + pkg/xtools/skywcs/doc/skequatorial.hlp | 58 + pkg/xtools/skywcs/doc/skiiprint.hlp | 39 + pkg/xtools/skywcs/doc/skiiwrite.hlp | 43 + pkg/xtools/skywcs/doc/sklltran.hlp | 59 + pkg/xtools/skywcs/doc/sksaveim.hlp | 39 + pkg/xtools/skywcs/doc/sksetd.hlp | 53 + pkg/xtools/skywcs/doc/skseti.hlp | 93 + pkg/xtools/skywcs/doc/sksets.hlp | 36 + pkg/xtools/skywcs/doc/skstatd.hlp | 49 + pkg/xtools/skywcs/doc/skstati.hlp | 79 + pkg/xtools/skywcs/doc/skstats.hlp | 40 + pkg/xtools/skywcs/doc/skultran.hlp | 50 + pkg/xtools/skywcs/doc/skywcs.hd | 25 + pkg/xtools/skywcs/doc/skywcs.hlp | 306 + pkg/xtools/skywcs/doc/skywcs.men | 15 + pkg/xtools/skywcs/mkpkg | 16 + pkg/xtools/skywcs/skdecode.x | 999 ++ pkg/xtools/skywcs/sksaveim.x | 157 + pkg/xtools/skywcs/skset.x | 90 + pkg/xtools/skywcs/skstat.x | 90 + pkg/xtools/skywcs/sktransform.x | 577 + pkg/xtools/skywcs/skwrdstr.x | 53 + pkg/xtools/skywcs/skwrite.x | 510 + pkg/xtools/skywcs/skywcs.h | 133 + pkg/xtools/skywcs/skywcsdef.h | 24 + pkg/xtools/strdetab.x | 30 + pkg/xtools/strentab.x | 38 + pkg/xtools/syshost.x | 232 + pkg/xtools/t_txtcompile.x | 62 + pkg/xtools/txtcompile | 3 + pkg/xtools/xt21imsum.x | 148 + pkg/xtools/xtanswer.h | 5 + pkg/xtools/xtanswer.x | 77 + pkg/xtools/xtargs.x | 141 + pkg/xtools/xtbitarray.x | 142 + pkg/xtools/xtextns.x | 587 + pkg/xtools/xtgids.x | 39 + pkg/xtools/xtimleneq.x | 22 + pkg/xtools/xtimnames.x | 102 + pkg/xtools/xtimtgetim.x | 52 + pkg/xtools/xtlogfiles.x | 93 + pkg/xtools/xtmaskname.x | 125 + pkg/xtools/xtmksection.x | 141 + pkg/xtools/xtphistory.x | 24 + pkg/xtools/xtsample.gx | 107 + pkg/xtools/xtsample.x | 362 + pkg/xtools/xtsort.x | 216 + pkg/xtools/xtstat.gx | 107 + pkg/xtools/xtstat.x | 337 + pkg/xtools/xtstripwhite.x | 18 + pkg/xtools/xtsums.x | 394 + pkg/xtools/xttxtfio.x | 71 + pkg/xtools/zzdebug.x | 51 + 4141 files changed, 913578 insertions(+) create mode 100644 pkg/README create mode 100644 pkg/bench/README create mode 100644 pkg/bench/bench.cl create mode 100644 pkg/bench/bench.hlp create mode 100644 pkg/bench/bench.ms create mode 100644 pkg/bench/bench_tab.ms create mode 100644 pkg/bench/fortask.cl create mode 100644 pkg/bench/mkpkg create mode 100644 pkg/bench/plots.cl create mode 100644 pkg/bench/subproc.cl create mode 100644 pkg/bench/x_bench.x create mode 100644 pkg/bench/xctest/README create mode 100644 pkg/bench/xctest/columns.x create mode 100644 pkg/bench/xctest/lintran.x create mode 100644 pkg/bench/xctest/mkpkg create mode 100644 pkg/bench/xctest/table.x create mode 100644 pkg/bench/xctest/tokens.x create mode 100644 pkg/bench/xctest/unique.x create mode 100644 pkg/bench/xctest/words.x create mode 100644 pkg/bench/xctest/x_lists.x create mode 100644 pkg/cl/README create mode 100644 pkg/cl/binop.c create mode 100644 pkg/cl/bkg.c create mode 100644 pkg/cl/builtin.c create mode 100644 pkg/cl/cl.par create mode 100644 pkg/cl/cl.x create mode 100644 pkg/cl/clmodes.h create mode 100644 pkg/cl/clprintf.c create mode 100644 pkg/cl/clsystem.c create mode 100644 pkg/cl/compile.c create mode 100644 pkg/cl/config.h create mode 100644 pkg/cl/construct.h create mode 100644 pkg/cl/debug.c create mode 100644 pkg/cl/decl.c create mode 100644 pkg/cl/doc/pset.sys create mode 100644 pkg/cl/edcap.c create mode 100644 pkg/cl/eparam.c create mode 100644 pkg/cl/eparam.h create mode 100644 pkg/cl/errs.c create mode 100644 pkg/cl/errs.h create mode 100644 pkg/cl/exec.c create mode 100644 pkg/cl/globals.c create mode 100644 pkg/cl/gquery.c create mode 100644 pkg/cl/gram.c create mode 100644 pkg/cl/grammar.h create mode 100644 pkg/cl/grammar.l create mode 100644 pkg/cl/grammar.y create mode 100644 pkg/cl/history.c create mode 100644 pkg/cl/lex.com create mode 100644 pkg/cl/lex.sed create mode 100644 pkg/cl/lexicon.c create mode 100644 pkg/cl/lexyy.c create mode 100644 pkg/cl/lists.c create mode 100644 pkg/cl/login.cl create mode 100644 pkg/cl/logout.cl create mode 100644 pkg/cl/main.c create mode 100644 pkg/cl/mem.h create mode 100644 pkg/cl/mkpkg create mode 100644 pkg/cl/modes.c create mode 100644 pkg/cl/opcodes.c create mode 100644 pkg/cl/opcodes.h create mode 100644 pkg/cl/operand.c create mode 100644 pkg/cl/operand.h create mode 100644 pkg/cl/param.c create mode 100644 pkg/cl/param.h create mode 100644 pkg/cl/pfiles.c create mode 100644 pkg/cl/prcache.c create mode 100644 pkg/cl/proto.h create mode 100644 pkg/cl/scan.c create mode 100644 pkg/cl/stack.c create mode 100644 pkg/cl/tags create mode 100644 pkg/cl/task.c create mode 100644 pkg/cl/task.h create mode 100644 pkg/cl/unop.c create mode 100644 pkg/cl/y.output create mode 100644 pkg/cl/ytab.c create mode 100644 pkg/cl/ytab.h create mode 100644 pkg/dataio/Revisions create mode 100644 pkg/dataio/bintext/mkpkg create mode 100644 pkg/dataio/bintext/t_bintxt.x create mode 100644 pkg/dataio/bintext/t_txtbin.x create mode 100644 pkg/dataio/bintxt.par create mode 100644 pkg/dataio/cardimage/conversion.x create mode 100644 pkg/dataio/cardimage/mkpkg create mode 100644 pkg/dataio/cardimage/rcardimage.com create mode 100644 pkg/dataio/cardimage/structure.hlp create mode 100644 pkg/dataio/cardimage/t_rcardimage.x create mode 100644 pkg/dataio/cardimage/t_wcardimage.x create mode 100644 pkg/dataio/cardimage/tabs.x create mode 100644 pkg/dataio/cardimage/wcardimage.com create mode 100644 pkg/dataio/dataio.cl create mode 100644 pkg/dataio/dataio.hd create mode 100644 pkg/dataio/dataio.men create mode 100644 pkg/dataio/dataio.par create mode 100644 pkg/dataio/doc/Mtio_notes create mode 100644 pkg/dataio/doc/Rfits_notes create mode 100644 pkg/dataio/doc/bintxt.hlp create mode 100644 pkg/dataio/doc/export.hlp create mode 100644 pkg/dataio/doc/import.hlp create mode 100644 pkg/dataio/doc/mtexamine.hlp create mode 100644 pkg/dataio/doc/rcardimage.hlp create mode 100644 pkg/dataio/doc/reblock.hlp create mode 100644 pkg/dataio/doc/rfits.hlp create mode 100644 pkg/dataio/doc/rtextimage.hlp create mode 100644 pkg/dataio/doc/t2d.hlp create mode 100644 pkg/dataio/doc/txtbin.hlp create mode 100644 pkg/dataio/doc/wcardimage.hlp create mode 100644 pkg/dataio/doc/wfits.hlp create mode 100644 pkg/dataio/doc/wtextimage.hlp create mode 100644 pkg/dataio/export.par create mode 100644 pkg/dataio/export/Notes create mode 100644 pkg/dataio/export/bltins/exeps.x create mode 100644 pkg/dataio/export/bltins/exgif.x create mode 100644 pkg/dataio/export/bltins/exiraf.x create mode 100644 pkg/dataio/export/bltins/exmiff.x create mode 100644 pkg/dataio/export/bltins/expgm.x create mode 100644 pkg/dataio/export/bltins/exppm.x create mode 100644 pkg/dataio/export/bltins/exras.x create mode 100644 pkg/dataio/export/bltins/exrgb.x create mode 100644 pkg/dataio/export/bltins/exvicar.x create mode 100644 pkg/dataio/export/bltins/exxwd.x create mode 100644 pkg/dataio/export/bltins/mkpkg create mode 100644 pkg/dataio/export/cmaps.inc create mode 100644 pkg/dataio/export/exbltins.h create mode 100644 pkg/dataio/export/exbltins.x create mode 100644 pkg/dataio/export/excmap.x create mode 100644 pkg/dataio/export/exfcn.h create mode 100644 pkg/dataio/export/exhdr.x create mode 100644 pkg/dataio/export/exobands.gx create mode 100644 pkg/dataio/export/export.h create mode 100644 pkg/dataio/export/expreproc.x create mode 100644 pkg/dataio/export/exraster.gx create mode 100644 pkg/dataio/export/exrgb8.x create mode 100644 pkg/dataio/export/exzscale.x create mode 100644 pkg/dataio/export/generic/exobands.x create mode 100644 pkg/dataio/export/generic/exraster.x create mode 100644 pkg/dataio/export/generic/mkpkg create mode 100644 pkg/dataio/export/mkpkg create mode 100644 pkg/dataio/export/t_export.x create mode 100644 pkg/dataio/export/zzedbg.x create mode 100644 pkg/dataio/fits/fits_cards.x create mode 100644 pkg/dataio/fits/fits_files.x create mode 100644 pkg/dataio/fits/fits_params.x create mode 100644 pkg/dataio/fits/fits_read.x create mode 100644 pkg/dataio/fits/fits_rheader.x create mode 100644 pkg/dataio/fits/fits_rimage.x create mode 100644 pkg/dataio/fits/fits_rpixels.x create mode 100644 pkg/dataio/fits/fits_wheader.x create mode 100644 pkg/dataio/fits/fits_wimage.x create mode 100644 pkg/dataio/fits/fits_wpixels.x create mode 100644 pkg/dataio/fits/fits_write.x create mode 100644 pkg/dataio/fits/mkpkg create mode 100644 pkg/dataio/fits/rfits.com create mode 100644 pkg/dataio/fits/rfits.h create mode 100644 pkg/dataio/fits/t_rfits.x create mode 100644 pkg/dataio/fits/t_wfits.x create mode 100644 pkg/dataio/fits/wfits.com create mode 100644 pkg/dataio/fits/wfits.h create mode 100644 pkg/dataio/import.par create mode 100644 pkg/dataio/import/README create mode 100644 pkg/dataio/import/bltins/README create mode 100644 pkg/dataio/import/bltins/ipcmap.x create mode 100644 pkg/dataio/import/bltins/ipgif.x create mode 100644 pkg/dataio/import/bltins/ipras.x create mode 100644 pkg/dataio/import/bltins/ipxwd.x create mode 100644 pkg/dataio/import/bltins/mkpkg create mode 100644 pkg/dataio/import/fmtdb.x create mode 100644 pkg/dataio/import/generic/ipdb.x create mode 100644 pkg/dataio/import/generic/ipfio.x create mode 100644 pkg/dataio/import/generic/ipobands.x create mode 100644 pkg/dataio/import/generic/ipproc.x create mode 100644 pkg/dataio/import/generic/mkpkg create mode 100644 pkg/dataio/import/images.dat create mode 100644 pkg/dataio/import/import.h create mode 100644 pkg/dataio/import/ipbuiltin.x create mode 100644 pkg/dataio/import/ipdb.gx create mode 100644 pkg/dataio/import/ipfcn.h create mode 100644 pkg/dataio/import/ipfio.gx create mode 100644 pkg/dataio/import/ipinfo.x create mode 100644 pkg/dataio/import/iplistpix.x create mode 100644 pkg/dataio/import/ipmkhdr.x create mode 100644 pkg/dataio/import/ipobands.gx create mode 100644 pkg/dataio/import/ipproc.gx create mode 100644 pkg/dataio/import/mkpkg create mode 100644 pkg/dataio/import/t_import.x create mode 100644 pkg/dataio/import/zzidbg.x create mode 100644 pkg/dataio/imtext/imtext.h create mode 100644 pkg/dataio/imtext/mkpkg create mode 100644 pkg/dataio/imtext/putcplx.x create mode 100644 pkg/dataio/imtext/putint.x create mode 100644 pkg/dataio/imtext/putreal.x create mode 100644 pkg/dataio/imtext/rt_cvtpix.x create mode 100644 pkg/dataio/imtext/rt_rheader.x create mode 100644 pkg/dataio/imtext/rt_rwpix.x create mode 100644 pkg/dataio/imtext/t_rtextimage.x create mode 100644 pkg/dataio/imtext/t_wtextimage.x create mode 100644 pkg/dataio/imtext/wtextimage.semi create mode 100644 pkg/dataio/imtext/wti_wheader.x create mode 100644 pkg/dataio/lib/addcards.x create mode 100644 pkg/dataio/lib/getdatatype.x create mode 100644 pkg/dataio/lib/mkpkg create mode 100644 pkg/dataio/lib/ranges.x create mode 100644 pkg/dataio/mkpkg create mode 100644 pkg/dataio/mtexamine.par create mode 100644 pkg/dataio/mtexamine/mkpkg create mode 100644 pkg/dataio/mtexamine/mtexamine.com create mode 100644 pkg/dataio/mtexamine/t_mtexamine.x create mode 100644 pkg/dataio/rcardimage.par create mode 100644 pkg/dataio/reblock.par create mode 100644 pkg/dataio/reblock/mkpkg create mode 100644 pkg/dataio/reblock/reblock.com create mode 100644 pkg/dataio/reblock/reblock.h create mode 100644 pkg/dataio/reblock/reblock.hlp create mode 100644 pkg/dataio/reblock/reblock_file.x create mode 100644 pkg/dataio/reblock/structure.hlp create mode 100644 pkg/dataio/reblock/t_reblock.x create mode 100644 pkg/dataio/rfits.par create mode 100644 pkg/dataio/rtextimage.par create mode 100644 pkg/dataio/t2d.par create mode 100644 pkg/dataio/t2d/mkpkg create mode 100644 pkg/dataio/t2d/t_t2d.x create mode 100644 pkg/dataio/txtbin.par create mode 100644 pkg/dataio/wcardimage.par create mode 100644 pkg/dataio/wfits.par create mode 100644 pkg/dataio/wtextimage.par create mode 100644 pkg/dataio/x_dataio.x create mode 100644 pkg/dbms/dbms.cl create mode 100644 pkg/dbms/dbms.par create mode 100644 pkg/ecl/Notes.ecl create mode 100644 pkg/ecl/README create mode 100644 pkg/ecl/Revisions create mode 100644 pkg/ecl/binop.c create mode 100644 pkg/ecl/bkg.c create mode 100644 pkg/ecl/builtin.c create mode 100755 pkg/ecl/cl.csh create mode 100755 pkg/ecl/cl.csh.SSOL create mode 100644 pkg/ecl/cl.par create mode 100644 pkg/ecl/clmodes.h create mode 100644 pkg/ecl/clprintf.c create mode 100644 pkg/ecl/clsystem.c create mode 100644 pkg/ecl/compile.c create mode 100644 pkg/ecl/config.h create mode 100644 pkg/ecl/construct.h create mode 100644 pkg/ecl/debug.c create mode 100644 pkg/ecl/decl.c create mode 100644 pkg/ecl/doc/ecl.hlp create mode 100644 pkg/ecl/doc/pset.sys create mode 100644 pkg/ecl/ecl.x create mode 100755 pkg/ecl/ecl_install.csh create mode 100644 pkg/ecl/edcap.c create mode 100644 pkg/ecl/eparam.c create mode 100644 pkg/ecl/eparam.h create mode 100644 pkg/ecl/errs.c create mode 100644 pkg/ecl/errs.h create mode 100644 pkg/ecl/errtest/errif.cl create mode 100644 pkg/ecl/errtest/errtest.cl create mode 100644 pkg/ecl/errtest/errtest.hd create mode 100644 pkg/ecl/errtest/errtest.men create mode 100644 pkg/ecl/errtest/errtest.par create mode 100644 pkg/ecl/errtest/errtype.cl create mode 100644 pkg/ecl/errtest/mkpkg create mode 100644 pkg/ecl/errtest/nest0.cl create mode 100644 pkg/ecl/errtest/nested.cl create mode 100644 pkg/ecl/errtest/printvals.cl create mode 100644 pkg/ecl/errtest/recur0.cl create mode 100644 pkg/ecl/errtest/recursion.cl create mode 100644 pkg/ecl/errtest/sfpe.cl create mode 100644 pkg/ecl/errtest/spperrs.x create mode 100644 pkg/ecl/errtest/test_iferr.cl create mode 100644 pkg/ecl/errtest/zztest.cl create mode 100644 pkg/ecl/exec.c create mode 100644 pkg/ecl/globals.c create mode 100644 pkg/ecl/gquery.c create mode 100644 pkg/ecl/gram.c create mode 100644 pkg/ecl/grammar.h create mode 100644 pkg/ecl/grammar.l create mode 100644 pkg/ecl/grammar.y create mode 100644 pkg/ecl/history.c create mode 100644 pkg/ecl/lex.com create mode 100644 pkg/ecl/lex.sed create mode 100644 pkg/ecl/lexicon.c create mode 100644 pkg/ecl/lexyy.c create mode 100644 pkg/ecl/lists.c create mode 100644 pkg/ecl/login.cl create mode 100644 pkg/ecl/logout.cl create mode 100644 pkg/ecl/main.c create mode 100644 pkg/ecl/mem.h create mode 100755 pkg/ecl/mkdist create mode 100644 pkg/ecl/mkpkg create mode 100644 pkg/ecl/modes.c create mode 100644 pkg/ecl/opcodes.c create mode 100644 pkg/ecl/opcodes.h create mode 100644 pkg/ecl/operand.c create mode 100644 pkg/ecl/operand.h create mode 100644 pkg/ecl/param.c create mode 100644 pkg/ecl/param.h create mode 100644 pkg/ecl/pfiles.c create mode 100644 pkg/ecl/prcache.c create mode 100644 pkg/ecl/proto.h create mode 100644 pkg/ecl/scan.c create mode 100644 pkg/ecl/stack.c create mode 100644 pkg/ecl/tags create mode 100644 pkg/ecl/task.c create mode 100644 pkg/ecl/task.h create mode 100644 pkg/ecl/unop.c create mode 100644 pkg/ecl/uparm/history.cl create mode 100644 pkg/ecl/y.output create mode 100644 pkg/ecl/ytab.c create mode 100644 pkg/ecl/ytab.h create mode 100644 pkg/ecl/zz.cl create mode 100644 pkg/images/README create mode 100644 pkg/images/Revisions create mode 100644 pkg/images/images.cl create mode 100644 pkg/images/images.hd create mode 100644 pkg/images/images.men create mode 100644 pkg/images/images.par create mode 100644 pkg/images/imcoords/Revisions create mode 100644 pkg/images/imcoords/ccfind.par create mode 100644 pkg/images/imcoords/ccget.par create mode 100644 pkg/images/imcoords/ccmap.par create mode 100644 pkg/images/imcoords/ccsetwcs.par create mode 100644 pkg/images/imcoords/ccstd.par create mode 100644 pkg/images/imcoords/cctran.par create mode 100644 pkg/images/imcoords/ccxymatch.par create mode 100644 pkg/images/imcoords/doc/ccfind.hlp create mode 100644 pkg/images/imcoords/doc/ccget.hlp create mode 100644 pkg/images/imcoords/doc/ccmap.hlp create mode 100644 pkg/images/imcoords/doc/ccsetwcs.hlp create mode 100644 pkg/images/imcoords/doc/ccstd.hlp create mode 100644 pkg/images/imcoords/doc/cctran.hlp create mode 100644 pkg/images/imcoords/doc/ccxymatch.hlp create mode 100644 pkg/images/imcoords/doc/hpctran.hlp create mode 100644 pkg/images/imcoords/doc/imcctran.hlp create mode 100644 pkg/images/imcoords/doc/mkcwcs.hlp create mode 100644 pkg/images/imcoords/doc/mkcwwcs.hlp create mode 100644 pkg/images/imcoords/doc/skyctran.hlp create mode 100644 pkg/images/imcoords/doc/starfind.hlp create mode 100644 pkg/images/imcoords/doc/wcsctran.hlp create mode 100644 pkg/images/imcoords/doc/wcsedit.hlp create mode 100644 pkg/images/imcoords/doc/wcsreset.hlp create mode 100644 pkg/images/imcoords/hpctran.par create mode 100644 pkg/images/imcoords/imcctran.par create mode 100644 pkg/images/imcoords/imcoords.cl create mode 100644 pkg/images/imcoords/imcoords.hd create mode 100644 pkg/images/imcoords/imcoords.men create mode 100644 pkg/images/imcoords/imcoords.par create mode 100644 pkg/images/imcoords/mkpkg create mode 100644 pkg/images/imcoords/skyctran.par create mode 100644 pkg/images/imcoords/src/ccfunc.x create mode 100644 pkg/images/imcoords/src/ccstd.x create mode 100644 pkg/images/imcoords/src/ccxytran.x create mode 100644 pkg/images/imcoords/src/healpix.x create mode 100644 pkg/images/imcoords/src/mkcwcs.cl create mode 100644 pkg/images/imcoords/src/mkcwwcs.cl create mode 100644 pkg/images/imcoords/src/mkpkg create mode 100644 pkg/images/imcoords/src/rgstr.gx create mode 100644 pkg/images/imcoords/src/rgstr.x create mode 100644 pkg/images/imcoords/src/sfconvolve.x create mode 100644 pkg/images/imcoords/src/sffind.x create mode 100644 pkg/images/imcoords/src/sftools.x create mode 100644 pkg/images/imcoords/src/skyctran.x create mode 100644 pkg/images/imcoords/src/skycur.key create mode 100644 pkg/images/imcoords/src/starfind.h create mode 100644 pkg/images/imcoords/src/t_ccfind.x create mode 100644 pkg/images/imcoords/src/t_ccget.x create mode 100644 pkg/images/imcoords/src/t_ccmap.x create mode 100644 pkg/images/imcoords/src/t_ccsetwcs.x create mode 100644 pkg/images/imcoords/src/t_ccstd.x create mode 100644 pkg/images/imcoords/src/t_cctran.x create mode 100644 pkg/images/imcoords/src/t_ccxymatch.x create mode 100644 pkg/images/imcoords/src/t_hpctran.x create mode 100644 pkg/images/imcoords/src/t_imcctran.x create mode 100644 pkg/images/imcoords/src/t_skyctran.x create mode 100644 pkg/images/imcoords/src/t_starfind.x create mode 100644 pkg/images/imcoords/src/t_wcsctran.x create mode 100644 pkg/images/imcoords/src/t_wcsedit.x create mode 100644 pkg/images/imcoords/src/t_wcsreset.x create mode 100644 pkg/images/imcoords/src/ttycur.key create mode 100644 pkg/images/imcoords/src/wcsedit.key create mode 100644 pkg/images/imcoords/src/x_starfind.x create mode 100644 pkg/images/imcoords/starfind.par create mode 100644 pkg/images/imcoords/wcsctran.par create mode 100644 pkg/images/imcoords/wcsedit.par create mode 100644 pkg/images/imcoords/wcsreset.par create mode 100644 pkg/images/imfilter/Revisions create mode 100644 pkg/images/imfilter/boxcar.par create mode 100644 pkg/images/imfilter/convolve.par create mode 100644 pkg/images/imfilter/doc/boxcar.hlp create mode 100644 pkg/images/imfilter/doc/convolve.hlp create mode 100644 pkg/images/imfilter/doc/fmedian.hlp create mode 100644 pkg/images/imfilter/doc/fmode.hlp create mode 100644 pkg/images/imfilter/doc/frmedian.hlp create mode 100644 pkg/images/imfilter/doc/frmode.hlp create mode 100644 pkg/images/imfilter/doc/gauss.hlp create mode 100644 pkg/images/imfilter/doc/gradient.hlp create mode 100644 pkg/images/imfilter/doc/laplace.hlp create mode 100644 pkg/images/imfilter/doc/median.hlp create mode 100644 pkg/images/imfilter/doc/mode.hlp create mode 100644 pkg/images/imfilter/doc/rmedian.hlp create mode 100644 pkg/images/imfilter/doc/rmode.hlp create mode 100644 pkg/images/imfilter/doc/runmed.hlp create mode 100644 pkg/images/imfilter/fmedian.par create mode 100644 pkg/images/imfilter/fmode.par create mode 100644 pkg/images/imfilter/frmedian.par create mode 100644 pkg/images/imfilter/frmode.par create mode 100644 pkg/images/imfilter/gauss.par create mode 100644 pkg/images/imfilter/gradient.par create mode 100644 pkg/images/imfilter/imfilter.cl create mode 100644 pkg/images/imfilter/imfilter.hd create mode 100644 pkg/images/imfilter/imfilter.men create mode 100644 pkg/images/imfilter/imfilter.par create mode 100644 pkg/images/imfilter/laplace.par create mode 100644 pkg/images/imfilter/median.par create mode 100644 pkg/images/imfilter/mkpkg create mode 100644 pkg/images/imfilter/mode.par create mode 100644 pkg/images/imfilter/rmedian.par create mode 100644 pkg/images/imfilter/rmode.par create mode 100644 pkg/images/imfilter/runmed.par create mode 100644 pkg/images/imfilter/src/aboxcar.x create mode 100644 pkg/images/imfilter/src/boxcar.x create mode 100644 pkg/images/imfilter/src/convolve.x create mode 100644 pkg/images/imfilter/src/fmd_buf.x create mode 100644 pkg/images/imfilter/src/fmd_hist.x create mode 100644 pkg/images/imfilter/src/fmd_maxmin.x create mode 100644 pkg/images/imfilter/src/fmedian.h create mode 100644 pkg/images/imfilter/src/fmedian.x create mode 100644 pkg/images/imfilter/src/fmode.h create mode 100644 pkg/images/imfilter/src/fmode.x create mode 100644 pkg/images/imfilter/src/frmedian.h create mode 100644 pkg/images/imfilter/src/frmedian.x create mode 100644 pkg/images/imfilter/src/frmode.h create mode 100644 pkg/images/imfilter/src/frmode.x create mode 100644 pkg/images/imfilter/src/med_buf.x create mode 100644 pkg/images/imfilter/src/med_sort.x create mode 100644 pkg/images/imfilter/src/med_utils.x create mode 100644 pkg/images/imfilter/src/median.h create mode 100644 pkg/images/imfilter/src/median.x create mode 100644 pkg/images/imfilter/src/mkpkg create mode 100644 pkg/images/imfilter/src/mode.h create mode 100644 pkg/images/imfilter/src/mode.x create mode 100644 pkg/images/imfilter/src/radcnv.x create mode 100644 pkg/images/imfilter/src/rmedian.h create mode 100644 pkg/images/imfilter/src/rmedian.x create mode 100644 pkg/images/imfilter/src/rmode.h create mode 100644 pkg/images/imfilter/src/rmode.x create mode 100644 pkg/images/imfilter/src/runmed.x create mode 100644 pkg/images/imfilter/src/t_boxcar.x create mode 100644 pkg/images/imfilter/src/t_convolve.x create mode 100644 pkg/images/imfilter/src/t_fmedian.x create mode 100644 pkg/images/imfilter/src/t_fmode.x create mode 100644 pkg/images/imfilter/src/t_frmedian.x create mode 100644 pkg/images/imfilter/src/t_frmode.x create mode 100644 pkg/images/imfilter/src/t_gauss.x create mode 100644 pkg/images/imfilter/src/t_gradient.x create mode 100644 pkg/images/imfilter/src/t_laplace.x create mode 100644 pkg/images/imfilter/src/t_median.x create mode 100644 pkg/images/imfilter/src/t_mode.x create mode 100644 pkg/images/imfilter/src/t_rmedian.x create mode 100644 pkg/images/imfilter/src/t_rmode.x create mode 100644 pkg/images/imfilter/src/t_runmed.x create mode 100644 pkg/images/imfilter/src/xyconvolve.x create mode 100644 pkg/images/imfit/Revisions create mode 100644 pkg/images/imfit/doc/fit1d.hlp create mode 100644 pkg/images/imfit/doc/imsurfit.hlp create mode 100644 pkg/images/imfit/doc/lineclean.hlp create mode 100644 pkg/images/imfit/fit1d.par create mode 100644 pkg/images/imfit/imfit.cl create mode 100644 pkg/images/imfit/imfit.hd create mode 100644 pkg/images/imfit/imfit.men create mode 100644 pkg/images/imfit/imfit.par create mode 100644 pkg/images/imfit/imsurfit.par create mode 100644 pkg/images/imfit/lineclean.par create mode 100644 pkg/images/imfit/mkpkg create mode 100644 pkg/images/imfit/src/fit1d.x create mode 100644 pkg/images/imfit/src/imsurfit.h create mode 100644 pkg/images/imfit/src/imsurfit.x create mode 100644 pkg/images/imfit/src/mkpkg create mode 100644 pkg/images/imfit/src/pixlist.h create mode 100644 pkg/images/imfit/src/pixlist.x create mode 100644 pkg/images/imfit/src/ranges.x create mode 100644 pkg/images/imfit/src/t_imsurfit.x create mode 100644 pkg/images/imfit/src/t_lineclean.x create mode 100644 pkg/images/imgeom/Revisions create mode 100644 pkg/images/imgeom/blkavg.par create mode 100644 pkg/images/imgeom/blkrep.par create mode 100644 pkg/images/imgeom/doc/blkavg.hlp create mode 100644 pkg/images/imgeom/doc/blkrep.hlp create mode 100644 pkg/images/imgeom/doc/im3dtran.hlp create mode 100644 pkg/images/imgeom/doc/imlintran.hlp create mode 100644 pkg/images/imgeom/doc/imshift.hlp create mode 100644 pkg/images/imgeom/doc/imtrans.hlp create mode 100644 pkg/images/imgeom/doc/magnify.hlp create mode 100644 pkg/images/imgeom/doc/rotate.hlp create mode 100644 pkg/images/imgeom/doc/shiftlines.hlp create mode 100644 pkg/images/imgeom/im3dtran.par create mode 100644 pkg/images/imgeom/imgeom.cl create mode 100644 pkg/images/imgeom/imgeom.hd create mode 100644 pkg/images/imgeom/imgeom.men create mode 100644 pkg/images/imgeom/imgeom.par create mode 100644 pkg/images/imgeom/imlintran.cl create mode 100644 pkg/images/imgeom/imlintran.par create mode 100644 pkg/images/imgeom/imshift.par create mode 100644 pkg/images/imgeom/imtranspose.par create mode 100644 pkg/images/imgeom/junk.cl create mode 100644 pkg/images/imgeom/magnify.par create mode 100644 pkg/images/imgeom/mkpkg create mode 100644 pkg/images/imgeom/rotate.cl create mode 100644 pkg/images/imgeom/rotate.par create mode 100644 pkg/images/imgeom/shiftlines.par create mode 100644 pkg/images/imgeom/src/blkav.gx create mode 100644 pkg/images/imgeom/src/blkcomp.x create mode 100644 pkg/images/imgeom/src/blkrp.gx create mode 100644 pkg/images/imgeom/src/generic/blkav.x create mode 100644 pkg/images/imgeom/src/generic/blkrp.x create mode 100644 pkg/images/imgeom/src/generic/im3dtran.x create mode 100644 pkg/images/imgeom/src/generic/imtrans.x create mode 100644 pkg/images/imgeom/src/generic/mkpkg create mode 100644 pkg/images/imgeom/src/im3dtran.gx create mode 100644 pkg/images/imgeom/src/imtrans.gx create mode 100644 pkg/images/imgeom/src/mkpkg create mode 100644 pkg/images/imgeom/src/shiftlines.x create mode 100644 pkg/images/imgeom/src/t_blkavg.x create mode 100644 pkg/images/imgeom/src/t_blkrep.x create mode 100644 pkg/images/imgeom/src/t_im3dtran.x create mode 100644 pkg/images/imgeom/src/t_imshift.x create mode 100644 pkg/images/imgeom/src/t_imtrans.x create mode 100644 pkg/images/imgeom/src/t_magnify.x create mode 100644 pkg/images/imgeom/src/t_shiftlines.x create mode 100644 pkg/images/immatch/Revisions create mode 100644 pkg/images/immatch/doc/geomap.hlp create mode 100644 pkg/images/immatch/doc/geotran.hlp create mode 100644 pkg/images/immatch/doc/geoxytran.hlp create mode 100644 pkg/images/immatch/doc/gregister.hlp create mode 100644 pkg/images/immatch/doc/imalign.hlp create mode 100644 pkg/images/immatch/doc/imcentroid.hlp create mode 100644 pkg/images/immatch/doc/imcombine.hlp create mode 100644 pkg/images/immatch/doc/linmatch.hlp create mode 100644 pkg/images/immatch/doc/psfmatch.hlp create mode 100644 pkg/images/immatch/doc/skymap.hlp create mode 100644 pkg/images/immatch/doc/skyxymatch.hlp create mode 100644 pkg/images/immatch/doc/sregister.hlp create mode 100644 pkg/images/immatch/doc/wcscopy.hlp create mode 100644 pkg/images/immatch/doc/wcsmap.hlp create mode 100644 pkg/images/immatch/doc/wcsxymatch.hlp create mode 100644 pkg/images/immatch/doc/wregister.hlp create mode 100644 pkg/images/immatch/doc/xregister.hlp create mode 100644 pkg/images/immatch/doc/xyxymatch.hlp create mode 100644 pkg/images/immatch/geomap.par create mode 100644 pkg/images/immatch/geotran.par create mode 100644 pkg/images/immatch/geoxytran.par create mode 100644 pkg/images/immatch/gregister.cl create mode 100644 pkg/images/immatch/gregister.par create mode 100644 pkg/images/immatch/imalign.cl create mode 100644 pkg/images/immatch/imalign.par create mode 100644 pkg/images/immatch/imcentroid.par create mode 100644 pkg/images/immatch/imcombine.par create mode 100644 pkg/images/immatch/immatch.cl create mode 100644 pkg/images/immatch/immatch.hd create mode 100644 pkg/images/immatch/immatch.men create mode 100644 pkg/images/immatch/immatch.par create mode 100644 pkg/images/immatch/linmatch.par create mode 100644 pkg/images/immatch/mkpkg create mode 100644 pkg/images/immatch/psfmatch.par create mode 100644 pkg/images/immatch/skymap.cl create mode 100644 pkg/images/immatch/skyxymatch.par create mode 100644 pkg/images/immatch/src/geometry/geofunc.gx create mode 100644 pkg/images/immatch/src/geometry/geofunc.x create mode 100644 pkg/images/immatch/src/geometry/geotimtran.x create mode 100644 pkg/images/immatch/src/geometry/geotran.h create mode 100644 pkg/images/immatch/src/geometry/geotran.x create mode 100644 pkg/images/immatch/src/geometry/geoxytran.gx create mode 100644 pkg/images/immatch/src/geometry/geoxytran.x create mode 100644 pkg/images/immatch/src/geometry/mkpkg create mode 100644 pkg/images/immatch/src/geometry/t_geomap.gx create mode 100644 pkg/images/immatch/src/geometry/t_geomap.x create mode 100644 pkg/images/immatch/src/geometry/t_geotran.x create mode 100644 pkg/images/immatch/src/geometry/t_geoxytran.x create mode 100644 pkg/images/immatch/src/geometry/trinvert.x create mode 100644 pkg/images/immatch/src/imcombine/imcombine.par create mode 100644 pkg/images/immatch/src/imcombine/mkpkg create mode 100644 pkg/images/immatch/src/imcombine/src/Revisions create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icaclip.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icaverage.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/iccclip.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icgdata.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icgrow.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icmedian.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icmm.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icnmodel.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icomb.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icpclip.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icquad.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icsclip.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icsigma.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icsort.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icstat.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/mkpkg create mode 100644 pkg/images/immatch/src/imcombine/src/generic/xtimmap.com create mode 100644 pkg/images/immatch/src/imcombine/src/generic/xtimmap.x create mode 100644 pkg/images/immatch/src/imcombine/src/icaclip.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icaverage.gx create mode 100644 pkg/images/immatch/src/imcombine/src/iccclip.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icemask.x create mode 100644 pkg/images/immatch/src/imcombine/src/icgdata.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icgrow.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icgscale.x create mode 100644 pkg/images/immatch/src/imcombine/src/ichdr.x create mode 100644 pkg/images/immatch/src/imcombine/src/icimstack.x create mode 100644 pkg/images/immatch/src/imcombine/src/iclog.x create mode 100644 pkg/images/immatch/src/imcombine/src/icmask.com create mode 100644 pkg/images/immatch/src/imcombine/src/icmask.h create mode 100644 pkg/images/immatch/src/imcombine/src/icmask.x create mode 100644 pkg/images/immatch/src/imcombine/src/icmedian.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icmm.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icnmodel.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icomb.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icombine.com create mode 100644 pkg/images/immatch/src/imcombine/src/icombine.h create mode 100644 pkg/images/immatch/src/imcombine/src/icombine.x create mode 100644 pkg/images/immatch/src/imcombine/src/icpclip.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icpmmap.x create mode 100644 pkg/images/immatch/src/imcombine/src/icquad.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icrmasks.x create mode 100644 pkg/images/immatch/src/imcombine/src/icscale.x create mode 100644 pkg/images/immatch/src/imcombine/src/icsclip.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icsection.x create mode 100644 pkg/images/immatch/src/imcombine/src/icsetout.x create mode 100644 pkg/images/immatch/src/imcombine/src/icsigma.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icsort.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icstat.gx create mode 100644 pkg/images/immatch/src/imcombine/src/mkpkg create mode 100644 pkg/images/immatch/src/imcombine/src/tymax.x create mode 100644 pkg/images/immatch/src/imcombine/src/xtimmap.gx create mode 100644 pkg/images/immatch/src/imcombine/src/xtprocid.x create mode 100644 pkg/images/immatch/src/imcombine/t_imcombine.x create mode 100644 pkg/images/immatch/src/imcombine/x_imcombine.x create mode 100644 pkg/images/immatch/src/linmatch/linmatch.h create mode 100644 pkg/images/immatch/src/linmatch/linmatch.key create mode 100644 pkg/images/immatch/src/linmatch/lsqfit.h create mode 100644 pkg/images/immatch/src/linmatch/mkpkg create mode 100644 pkg/images/immatch/src/linmatch/rglcolon.x create mode 100644 pkg/images/immatch/src/linmatch/rgldbio.x create mode 100644 pkg/images/immatch/src/linmatch/rgldelete.x create mode 100644 pkg/images/immatch/src/linmatch/rgliscale.x create mode 100644 pkg/images/immatch/src/linmatch/rglpars.x create mode 100644 pkg/images/immatch/src/linmatch/rglplot.x create mode 100644 pkg/images/immatch/src/linmatch/rglregions.x create mode 100644 pkg/images/immatch/src/linmatch/rglscale.x create mode 100644 pkg/images/immatch/src/linmatch/rglshow.x create mode 100644 pkg/images/immatch/src/linmatch/rglsqfit.x create mode 100644 pkg/images/immatch/src/linmatch/rgltools.x create mode 100644 pkg/images/immatch/src/linmatch/t_linmatch.x create mode 100644 pkg/images/immatch/src/listmatch/mkpkg create mode 100644 pkg/images/immatch/src/listmatch/t_imctroid.x create mode 100644 pkg/images/immatch/src/listmatch/t_xyxymatch.x create mode 100644 pkg/images/immatch/src/mkpkg create mode 100644 pkg/images/immatch/src/psfmatch/mkpkg create mode 100644 pkg/images/immatch/src/psfmatch/psfmatch.h create mode 100644 pkg/images/immatch/src/psfmatch/psfmatch.key create mode 100644 pkg/images/immatch/src/psfmatch/rgpbckgrd.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpcolon.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpconvolve.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpfft.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpfilter.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpisfm.x create mode 100644 pkg/images/immatch/src/psfmatch/rgppars.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpregions.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpsfm.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpshow.x create mode 100644 pkg/images/immatch/src/psfmatch/rgptools.x create mode 100644 pkg/images/immatch/src/psfmatch/t_psfmatch.x create mode 100644 pkg/images/immatch/src/wcsmatch/mkpkg create mode 100644 pkg/images/immatch/src/wcsmatch/rgmatchio.x create mode 100644 pkg/images/immatch/src/wcsmatch/t_skyxymatch.x create mode 100644 pkg/images/immatch/src/wcsmatch/t_wcscopy.x create mode 100644 pkg/images/immatch/src/wcsmatch/t_wcsxymatch.x create mode 100644 pkg/images/immatch/src/wcsmatch/wcsxymatch.h create mode 100644 pkg/images/immatch/src/xregister/mkpkg create mode 100644 pkg/images/immatch/src/xregister/oxregister.key create mode 100644 pkg/images/immatch/src/xregister/rgxbckgrd.x create mode 100644 pkg/images/immatch/src/xregister/rgxcolon.x create mode 100644 pkg/images/immatch/src/xregister/rgxcorr.x create mode 100644 pkg/images/immatch/src/xregister/rgxdbio.x create mode 100644 pkg/images/immatch/src/xregister/rgxfft.x create mode 100644 pkg/images/immatch/src/xregister/rgxfit.x create mode 100644 pkg/images/immatch/src/xregister/rgxgpars.x create mode 100644 pkg/images/immatch/src/xregister/rgxicorr.x create mode 100644 pkg/images/immatch/src/xregister/rgximshift.x create mode 100644 pkg/images/immatch/src/xregister/rgxplot.x create mode 100644 pkg/images/immatch/src/xregister/rgxppars.x create mode 100644 pkg/images/immatch/src/xregister/rgxregions.x create mode 100644 pkg/images/immatch/src/xregister/rgxshow.x create mode 100644 pkg/images/immatch/src/xregister/rgxtools.x create mode 100644 pkg/images/immatch/src/xregister/rgxtransform.x create mode 100644 pkg/images/immatch/src/xregister/t_xregister.x create mode 100644 pkg/images/immatch/src/xregister/xregister.h create mode 100644 pkg/images/immatch/src/xregister/xregister.key create mode 100644 pkg/images/immatch/sregister.cl create mode 100644 pkg/images/immatch/wcscopy.par create mode 100644 pkg/images/immatch/wcsmap.cl create mode 100644 pkg/images/immatch/wcsxymatch.par create mode 100644 pkg/images/immatch/wregister.cl create mode 100644 pkg/images/immatch/xregister.par create mode 100644 pkg/images/immatch/xyxymatch.par create mode 100644 pkg/images/imutil/Revisions create mode 100644 pkg/images/imutil/_imaxes.par create mode 100644 pkg/images/imutil/chpixtype.par create mode 100644 pkg/images/imutil/doc/chpix.hlp create mode 100644 pkg/images/imutil/doc/hedit.hlp create mode 100644 pkg/images/imutil/doc/hselect.hlp create mode 100644 pkg/images/imutil/doc/imarith.hlp create mode 100644 pkg/images/imutil/doc/imcopy.hlp create mode 100644 pkg/images/imutil/doc/imdelete.hlp create mode 100644 pkg/images/imutil/doc/imdivide.hlp create mode 100644 pkg/images/imutil/doc/imexpr.hlp create mode 100644 pkg/images/imutil/doc/imfunction.hlp create mode 100644 pkg/images/imutil/doc/imgets.hlp create mode 100644 pkg/images/imutil/doc/imheader.hlp create mode 100644 pkg/images/imutil/doc/imhistogram.hlp create mode 100644 pkg/images/imutil/doc/imjoin.hlp create mode 100644 pkg/images/imutil/doc/imrename.hlp create mode 100644 pkg/images/imutil/doc/imreplace.hlp create mode 100644 pkg/images/imutil/doc/imslice.hlp create mode 100644 pkg/images/imutil/doc/imstack.hlp create mode 100644 pkg/images/imutil/doc/imstat.hlp create mode 100644 pkg/images/imutil/doc/imsum.hlp create mode 100644 pkg/images/imutil/doc/imtile.hlp create mode 100644 pkg/images/imutil/doc/listpixels.hlp create mode 100644 pkg/images/imutil/doc/minmax.hlp create mode 100644 pkg/images/imutil/doc/nhedit.hlp create mode 100644 pkg/images/imutil/doc/sections.hlp create mode 100644 pkg/images/imutil/hedit.par create mode 100644 pkg/images/imutil/hselect.par create mode 100644 pkg/images/imutil/imarith.par create mode 100644 pkg/images/imutil/imcopy.par create mode 100644 pkg/images/imutil/imdelete.par create mode 100644 pkg/images/imutil/imdivide.par create mode 100644 pkg/images/imutil/imexpr.par create mode 100644 pkg/images/imutil/imfunction.par create mode 100644 pkg/images/imutil/imgets.par create mode 100644 pkg/images/imutil/imheader.par create mode 100644 pkg/images/imutil/imhistogram.par create mode 100644 pkg/images/imutil/imjoin.par create mode 100644 pkg/images/imutil/imrename.par create mode 100644 pkg/images/imutil/imreplace.par create mode 100644 pkg/images/imutil/imslice.par create mode 100644 pkg/images/imutil/imstack.par create mode 100644 pkg/images/imutil/imstatistics.par create mode 100644 pkg/images/imutil/imsum.par create mode 100644 pkg/images/imutil/imtile.par create mode 100644 pkg/images/imutil/imutil.cl create mode 100644 pkg/images/imutil/imutil.hd create mode 100644 pkg/images/imutil/imutil.men create mode 100644 pkg/images/imutil/imutil.par create mode 100644 pkg/images/imutil/listpixels.par create mode 100644 pkg/images/imutil/minmax.par create mode 100644 pkg/images/imutil/mkpkg create mode 100644 pkg/images/imutil/nhedit.par create mode 100644 pkg/images/imutil/sections.par create mode 100644 pkg/images/imutil/src/generic/imaadd.x create mode 100644 pkg/images/imutil/src/generic/imadiv.x create mode 100644 pkg/images/imutil/src/generic/imamax.x create mode 100644 pkg/images/imutil/src/generic/imamin.x create mode 100644 pkg/images/imutil/src/generic/imamul.x create mode 100644 pkg/images/imutil/src/generic/imanl.x create mode 100644 pkg/images/imutil/src/generic/imasub.x create mode 100644 pkg/images/imutil/src/generic/imfuncs.x create mode 100644 pkg/images/imutil/src/generic/imjoin.x create mode 100644 pkg/images/imutil/src/generic/imrep.x create mode 100644 pkg/images/imutil/src/generic/imsum.x create mode 100644 pkg/images/imutil/src/generic/mkpkg create mode 100644 pkg/images/imutil/src/getcmd.x create mode 100644 pkg/images/imutil/src/gettok.h create mode 100644 pkg/images/imutil/src/gettok.x create mode 100644 pkg/images/imutil/src/hedit.x create mode 100644 pkg/images/imutil/src/hselect.x create mode 100644 pkg/images/imutil/src/iegsym.x create mode 100644 pkg/images/imutil/src/imaadd.gx create mode 100644 pkg/images/imutil/src/imadiv.gx create mode 100644 pkg/images/imutil/src/imamax.gx create mode 100644 pkg/images/imutil/src/imamin.gx create mode 100644 pkg/images/imutil/src/imamul.gx create mode 100644 pkg/images/imutil/src/imanl.gx create mode 100644 pkg/images/imutil/src/imasub.gx create mode 100644 pkg/images/imutil/src/imdelete.x create mode 100644 pkg/images/imutil/src/imexpr.gx create mode 100644 pkg/images/imutil/src/imexpr.x create mode 100644 pkg/images/imutil/src/imfuncs.gx create mode 100644 pkg/images/imutil/src/imfunction.x create mode 100644 pkg/images/imutil/src/imgets.x create mode 100644 pkg/images/imutil/src/imheader.x create mode 100644 pkg/images/imutil/src/imhistogram.x create mode 100644 pkg/images/imutil/src/imjoin.gx create mode 100644 pkg/images/imutil/src/imminmax.x create mode 100644 pkg/images/imutil/src/imrep.gx create mode 100644 pkg/images/imutil/src/imstat.h create mode 100644 pkg/images/imutil/src/imsum.gx create mode 100644 pkg/images/imutil/src/imsum.h create mode 100644 pkg/images/imutil/src/imtile.h create mode 100644 pkg/images/imutil/src/listpixels.x create mode 100644 pkg/images/imutil/src/minmax.x create mode 100644 pkg/images/imutil/src/mkpkg create mode 100644 pkg/images/imutil/src/nhedit.x create mode 100644 pkg/images/imutil/src/t_chpix.x create mode 100644 pkg/images/imutil/src/t_imarith.x create mode 100644 pkg/images/imutil/src/t_imaxes.x create mode 100644 pkg/images/imutil/src/t_imcopy.x create mode 100644 pkg/images/imutil/src/t_imdivide.x create mode 100644 pkg/images/imutil/src/t_imjoin.x create mode 100644 pkg/images/imutil/src/t_imrename.x create mode 100644 pkg/images/imutil/src/t_imreplace.x create mode 100644 pkg/images/imutil/src/t_imslice.x create mode 100644 pkg/images/imutil/src/t_imstack.x create mode 100644 pkg/images/imutil/src/t_imstat.x create mode 100644 pkg/images/imutil/src/t_imsum.x create mode 100644 pkg/images/imutil/src/t_imtile.x create mode 100644 pkg/images/imutil/src/t_minmax.x create mode 100644 pkg/images/imutil/src/t_sections.x create mode 100644 pkg/images/lib/coomap.key create mode 100644 pkg/images/lib/geofit.gx create mode 100644 pkg/images/lib/geofit.x create mode 100644 pkg/images/lib/geofiti.x create mode 100644 pkg/images/lib/geogmap.gx create mode 100644 pkg/images/lib/geogmap.h create mode 100644 pkg/images/lib/geogmap.x create mode 100644 pkg/images/lib/geogmapi.x create mode 100644 pkg/images/lib/geograph.gx create mode 100644 pkg/images/lib/geograph.x create mode 100644 pkg/images/lib/geomap.h create mode 100644 pkg/images/lib/geomap.key create mode 100644 pkg/images/lib/geoset.x create mode 100644 pkg/images/lib/imcopy.x create mode 100644 pkg/images/lib/liststr.gx create mode 100644 pkg/images/lib/liststr.x create mode 100644 pkg/images/lib/mkpkg create mode 100644 pkg/images/lib/rgbckgrd.x create mode 100644 pkg/images/lib/rgccwcs.x create mode 100644 pkg/images/lib/rgcontour.x create mode 100644 pkg/images/lib/rgfft.x create mode 100644 pkg/images/lib/rglltran.x create mode 100644 pkg/images/lib/rgmerge.x create mode 100644 pkg/images/lib/rgsort.x create mode 100644 pkg/images/lib/rgtransform.x create mode 100644 pkg/images/lib/rgwrdstr.x create mode 100644 pkg/images/lib/rgxymatch.x create mode 100644 pkg/images/lib/xymatch.x create mode 100644 pkg/images/lib/xyxymatch.h create mode 100644 pkg/images/lib/zzdebug.x create mode 100644 pkg/images/mkpkg create mode 100644 pkg/images/notes create mode 100644 pkg/images/tv/Revisions create mode 100644 pkg/images/tv/_dcontrol.par create mode 100644 pkg/images/tv/cimexam.par create mode 100644 pkg/images/tv/display.par create mode 100644 pkg/images/tv/display/README create mode 100755 pkg/images/tv/display/ace.h create mode 100644 pkg/images/tv/display/display.h create mode 100644 pkg/images/tv/display/dsmap.x create mode 100644 pkg/images/tv/display/dspmmap.x create mode 100644 pkg/images/tv/display/dsulut.x create mode 100644 pkg/images/tv/display/findz.x create mode 100644 pkg/images/tv/display/gwindow.h create mode 100644 pkg/images/tv/display/iis.com create mode 100644 pkg/images/tv/display/iis.h create mode 100644 pkg/images/tv/display/iisblk.x create mode 100644 pkg/images/tv/display/iiscls.x create mode 100644 pkg/images/tv/display/iisers.x create mode 100644 pkg/images/tv/display/iisflu.x create mode 100644 pkg/images/tv/display/iisgop.x create mode 100644 pkg/images/tv/display/iishdr.x create mode 100644 pkg/images/tv/display/iisio.x create mode 100644 pkg/images/tv/display/iismtc.x create mode 100644 pkg/images/tv/display/iisofm.x create mode 100644 pkg/images/tv/display/iisopn.x create mode 100644 pkg/images/tv/display/iispio.x create mode 100644 pkg/images/tv/display/iisrcr.x create mode 100644 pkg/images/tv/display/iisrd.x create mode 100644 pkg/images/tv/display/iisrgb.x create mode 100644 pkg/images/tv/display/iissfr.x create mode 100644 pkg/images/tv/display/iisstt.x create mode 100644 pkg/images/tv/display/iiswcr.x create mode 100644 pkg/images/tv/display/iiswnd.x create mode 100644 pkg/images/tv/display/iiswr.x create mode 100644 pkg/images/tv/display/iiswt.x create mode 100644 pkg/images/tv/display/iiszm.x create mode 100644 pkg/images/tv/display/imd.com create mode 100644 pkg/images/tv/display/imdgcur.x create mode 100644 pkg/images/tv/display/imdgetwcs.x create mode 100644 pkg/images/tv/display/imdmapfr.x create mode 100644 pkg/images/tv/display/imdmapping.x create mode 100644 pkg/images/tv/display/imdopen.x create mode 100644 pkg/images/tv/display/imdputwcs.x create mode 100644 pkg/images/tv/display/imdrcur.x create mode 100644 pkg/images/tv/display/imdrcuro.x create mode 100644 pkg/images/tv/display/imdsetwcs.x create mode 100644 pkg/images/tv/display/imdwcs.x create mode 100644 pkg/images/tv/display/imdwcsver.x create mode 100644 pkg/images/tv/display/maskcolor.x create mode 100644 pkg/images/tv/display/maxmin.x create mode 100644 pkg/images/tv/display/mkpkg create mode 100644 pkg/images/tv/display/sigl2.x create mode 100644 pkg/images/tv/display/sigm2.x create mode 100644 pkg/images/tv/display/t_dcontrol.x create mode 100644 pkg/images/tv/display/t_display.x create mode 100644 pkg/images/tv/display/zardim.x create mode 100644 pkg/images/tv/display/zawrim.x create mode 100644 pkg/images/tv/display/zawtim.x create mode 100644 pkg/images/tv/display/zblkim.x create mode 100644 pkg/images/tv/display/zclrim.x create mode 100644 pkg/images/tv/display/zclsim.x create mode 100644 pkg/images/tv/display/zdisplay.h create mode 100644 pkg/images/tv/display/zersim.x create mode 100644 pkg/images/tv/display/zfrmim.x create mode 100644 pkg/images/tv/display/zmapim.x create mode 100644 pkg/images/tv/display/zmtcim.x create mode 100644 pkg/images/tv/display/zopnim.x create mode 100644 pkg/images/tv/display/zrcrim.x create mode 100644 pkg/images/tv/display/zrgbim.x create mode 100644 pkg/images/tv/display/zrmim.x create mode 100644 pkg/images/tv/display/zscale.x create mode 100644 pkg/images/tv/display/zsttim.x create mode 100644 pkg/images/tv/display/zwndim.x create mode 100644 pkg/images/tv/display/zzdebug.x create mode 100644 pkg/images/tv/doc/Tv.hlp create mode 100644 pkg/images/tv/doc/bpmedit.hlp create mode 100644 pkg/images/tv/doc/display.hlp create mode 100644 pkg/images/tv/doc/imedit.hlp create mode 100644 pkg/images/tv/doc/imexamine.hlp create mode 100644 pkg/images/tv/doc/tvmark.hlp create mode 100644 pkg/images/tv/doc/wcslab.hlp create mode 100644 pkg/images/tv/eimexam.par create mode 100644 pkg/images/tv/himexam.par create mode 100644 pkg/images/tv/iis/README create mode 100644 pkg/images/tv/iis/blink.cl create mode 100644 pkg/images/tv/iis/blink.par create mode 100644 pkg/images/tv/iis/cv.par create mode 100644 pkg/images/tv/iis/cvl.par create mode 100644 pkg/images/tv/iis/doc/Cv.spc.hlp create mode 100644 pkg/images/tv/iis/doc/blink.hlp create mode 100644 pkg/images/tv/iis/doc/cv.doc create mode 100644 pkg/images/tv/iis/doc/cv.hlp create mode 100644 pkg/images/tv/iis/doc/cv.ms create mode 100644 pkg/images/tv/iis/doc/cvl.hlp create mode 100644 pkg/images/tv/iis/doc/erase.hlp create mode 100644 pkg/images/tv/iis/doc/frame.hlp create mode 100644 pkg/images/tv/iis/doc/lumatch.hlp create mode 100644 pkg/images/tv/iis/doc/monochrome.hlp create mode 100644 pkg/images/tv/iis/doc/pseudocolor.hlp create mode 100644 pkg/images/tv/iis/doc/rgb.hlp create mode 100644 pkg/images/tv/iis/doc/window.hlp create mode 100644 pkg/images/tv/iis/doc/zoom.hlp create mode 100644 pkg/images/tv/iis/erase.cl create mode 100644 pkg/images/tv/iis/erase.par create mode 100644 pkg/images/tv/iis/frame.cl create mode 100644 pkg/images/tv/iis/giis.par create mode 100644 pkg/images/tv/iis/ids/doc/Imdis.hlp create mode 100644 pkg/images/tv/iis/ids/doc/Note.misc create mode 100644 pkg/images/tv/iis/ids/doc/Note.pixel create mode 100644 pkg/images/tv/iis/ids/doc/file.doc create mode 100644 pkg/images/tv/iis/ids/doc/iis.doc create mode 100644 pkg/images/tv/iis/ids/font.com create mode 100644 pkg/images/tv/iis/ids/font.h create mode 100644 pkg/images/tv/iis/ids/idscancel.x create mode 100644 pkg/images/tv/iis/ids/idschars.x create mode 100644 pkg/images/tv/iis/ids/idsclear.x create mode 100644 pkg/images/tv/iis/ids/idsclose.x create mode 100644 pkg/images/tv/iis/ids/idsclosews.x create mode 100644 pkg/images/tv/iis/ids/idscround.x create mode 100644 pkg/images/tv/iis/ids/idsdrawch.x create mode 100644 pkg/images/tv/iis/ids/idsescape.x create mode 100644 pkg/images/tv/iis/ids/idsfa.x create mode 100644 pkg/images/tv/iis/ids/idsfaset.x create mode 100644 pkg/images/tv/iis/ids/idsflush.x create mode 100644 pkg/images/tv/iis/ids/idsfont.x create mode 100644 pkg/images/tv/iis/ids/idsgcell.x create mode 100644 pkg/images/tv/iis/ids/idsgcur.x create mode 100644 pkg/images/tv/iis/ids/idsinit.x create mode 100644 pkg/images/tv/iis/ids/idsline.x create mode 100644 pkg/images/tv/iis/ids/idslutfill.x create mode 100644 pkg/images/tv/iis/ids/idsopen.x create mode 100644 pkg/images/tv/iis/ids/idsopenws.x create mode 100644 pkg/images/tv/iis/ids/idspcell.x create mode 100644 pkg/images/tv/iis/ids/idspl.x create mode 100644 pkg/images/tv/iis/ids/idsplset.x create mode 100644 pkg/images/tv/iis/ids/idspm.x create mode 100644 pkg/images/tv/iis/ids/idspmset.x create mode 100644 pkg/images/tv/iis/ids/idspoint.x create mode 100644 pkg/images/tv/iis/ids/idsreset.x create mode 100644 pkg/images/tv/iis/ids/idsrestore.x create mode 100644 pkg/images/tv/iis/ids/idssave.x create mode 100644 pkg/images/tv/iis/ids/idsscur.x create mode 100644 pkg/images/tv/iis/ids/idsstream.x create mode 100644 pkg/images/tv/iis/ids/idstx.x create mode 100644 pkg/images/tv/iis/ids/idstxset.x create mode 100644 pkg/images/tv/iis/ids/idsvector.x create mode 100644 pkg/images/tv/iis/ids/mkpkg create mode 100644 pkg/images/tv/iis/ids/testcode/README create mode 100644 pkg/images/tv/iis/ids/testcode/box.x create mode 100644 pkg/images/tv/iis/ids/testcode/boxin.x create mode 100644 pkg/images/tv/iis/ids/testcode/crin.x create mode 100644 pkg/images/tv/iis/ids/testcode/grey.x create mode 100644 pkg/images/tv/iis/ids/testcode/grin.x create mode 100644 pkg/images/tv/iis/ids/testcode/scr.x create mode 100644 pkg/images/tv/iis/ids/testcode/scrin.x create mode 100644 pkg/images/tv/iis/ids/testcode/sn.x create mode 100644 pkg/images/tv/iis/ids/testcode/t_giis.x create mode 100644 pkg/images/tv/iis/ids/testcode/zm.x create mode 100644 pkg/images/tv/iis/ids/testcode/zmin.x create mode 100644 pkg/images/tv/iis/ids/testcode/zztest.x create mode 100644 pkg/images/tv/iis/iis.cl create mode 100644 pkg/images/tv/iis/iis.hd create mode 100644 pkg/images/tv/iis/iis.men create mode 100644 pkg/images/tv/iis/iis.par create mode 100644 pkg/images/tv/iis/iism70/README create mode 100644 pkg/images/tv/iis/iism70/idsexpand.x create mode 100644 pkg/images/tv/iis/iism70/iis.com create mode 100644 pkg/images/tv/iis/iism70/iis.h create mode 100644 pkg/images/tv/iis/iism70/iisbutton.x create mode 100644 pkg/images/tv/iis/iism70/iiscls.x create mode 100644 pkg/images/tv/iis/iism70/iiscursor.x create mode 100644 pkg/images/tv/iis/iism70/iishdr.x create mode 100644 pkg/images/tv/iis/iism70/iishisto.x create mode 100644 pkg/images/tv/iis/iism70/iisifm.x create mode 100644 pkg/images/tv/iis/iism70/iisio.x create mode 100644 pkg/images/tv/iis/iism70/iislut.x create mode 100644 pkg/images/tv/iis/iism70/iismatch.x create mode 100644 pkg/images/tv/iis/iism70/iisminmax.x create mode 100644 pkg/images/tv/iis/iism70/iisoffset.x create mode 100644 pkg/images/tv/iis/iism70/iisofm.x create mode 100644 pkg/images/tv/iis/iism70/iisopn.x create mode 100644 pkg/images/tv/iis/iism70/iispack.x create mode 100644 pkg/images/tv/iis/iism70/iispio.x create mode 100644 pkg/images/tv/iis/iism70/iisrange.x create mode 100644 pkg/images/tv/iis/iism70/iisrd.x create mode 100644 pkg/images/tv/iis/iism70/iisscroll.x create mode 100644 pkg/images/tv/iis/iism70/iissplit.x create mode 100644 pkg/images/tv/iis/iism70/iistball.x create mode 100644 pkg/images/tv/iis/iism70/iiswr.x create mode 100644 pkg/images/tv/iis/iism70/iiswt.x create mode 100644 pkg/images/tv/iis/iism70/iiszoom.x create mode 100644 pkg/images/tv/iis/iism70/mkpkg create mode 100644 pkg/images/tv/iis/iism70/zardim.x create mode 100644 pkg/images/tv/iis/iism70/zawrim.x create mode 100644 pkg/images/tv/iis/iism70/zawtim.x create mode 100644 pkg/images/tv/iis/iism70/zclear.x create mode 100644 pkg/images/tv/iis/iism70/zclsim.x create mode 100644 pkg/images/tv/iis/iism70/zcontrol.x create mode 100644 pkg/images/tv/iis/iism70/zcursor_read.x create mode 100644 pkg/images/tv/iis/iism70/zcursor_set.x create mode 100644 pkg/images/tv/iis/iism70/zdisplay_g.x create mode 100644 pkg/images/tv/iis/iism70/zdisplay_i.x create mode 100644 pkg/images/tv/iis/iism70/zinit.x create mode 100644 pkg/images/tv/iis/iism70/zopnim.x create mode 100644 pkg/images/tv/iis/iism70/zreset.x create mode 100644 pkg/images/tv/iis/iism70/zrestore.x create mode 100644 pkg/images/tv/iis/iism70/zsave.x create mode 100644 pkg/images/tv/iis/iism70/zseek.x create mode 100644 pkg/images/tv/iis/iism70/zsetup.x create mode 100644 pkg/images/tv/iis/iism70/zsnap.com create mode 100644 pkg/images/tv/iis/iism70/zsnap.x create mode 100644 pkg/images/tv/iis/iism70/zsnapinit.x create mode 100644 pkg/images/tv/iis/iism70/zsttim.x create mode 100644 pkg/images/tv/iis/lib/ids.com create mode 100644 pkg/images/tv/iis/lib/ids.h create mode 100644 pkg/images/tv/iis/lumatch.cl create mode 100644 pkg/images/tv/iis/lumatch.par create mode 100644 pkg/images/tv/iis/mkpkg create mode 100644 pkg/images/tv/iis/monochrome.cl create mode 100644 pkg/images/tv/iis/pseudocolor.cl create mode 100644 pkg/images/tv/iis/pseudocolor.par create mode 100644 pkg/images/tv/iis/rgb.cl create mode 100644 pkg/images/tv/iis/rgb.par create mode 100644 pkg/images/tv/iis/src/blink.x create mode 100644 pkg/images/tv/iis/src/clear.x create mode 100644 pkg/images/tv/iis/src/cv.com create mode 100644 pkg/images/tv/iis/src/cv.h create mode 100644 pkg/images/tv/iis/src/cv.x create mode 100644 pkg/images/tv/iis/src/cvparse.x create mode 100644 pkg/images/tv/iis/src/cvulut.x create mode 100644 pkg/images/tv/iis/src/cvutil.x create mode 100644 pkg/images/tv/iis/src/display.x create mode 100644 pkg/images/tv/iis/src/gwindow.h create mode 100644 pkg/images/tv/iis/src/load1.x create mode 100644 pkg/images/tv/iis/src/load2.x create mode 100644 pkg/images/tv/iis/src/map.x create mode 100644 pkg/images/tv/iis/src/match.x create mode 100644 pkg/images/tv/iis/src/maxmin.x create mode 100644 pkg/images/tv/iis/src/mkpkg create mode 100644 pkg/images/tv/iis/src/offset.x create mode 100644 pkg/images/tv/iis/src/pan.x create mode 100644 pkg/images/tv/iis/src/range.x create mode 100644 pkg/images/tv/iis/src/rdcur.x create mode 100644 pkg/images/tv/iis/src/reset.x create mode 100644 pkg/images/tv/iis/src/sigl2.x create mode 100644 pkg/images/tv/iis/src/snap.x create mode 100644 pkg/images/tv/iis/src/split.x create mode 100644 pkg/images/tv/iis/src/tell.x create mode 100644 pkg/images/tv/iis/src/text.x create mode 100644 pkg/images/tv/iis/src/window.x create mode 100644 pkg/images/tv/iis/src/zoom.x create mode 100644 pkg/images/tv/iis/src/zscale.x create mode 100644 pkg/images/tv/iis/window.cl create mode 100644 pkg/images/tv/iis/x_iis.x create mode 100644 pkg/images/tv/iis/zoom.cl create mode 100644 pkg/images/tv/iis/zoom.par create mode 100644 pkg/images/tv/imedit.par create mode 100644 pkg/images/tv/imedit/bpmedit.cl create mode 100644 pkg/images/tv/imedit/bpmedit.key create mode 100644 pkg/images/tv/imedit/epbackground.x create mode 100644 pkg/images/tv/imedit/epcol.x create mode 100644 pkg/images/tv/imedit/epcolon.x create mode 100644 pkg/images/tv/imedit/epconstant.x create mode 100644 pkg/images/tv/imedit/epdisplay.x create mode 100644 pkg/images/tv/imedit/epdosurface.x create mode 100644 pkg/images/tv/imedit/epgcur.x create mode 100644 pkg/images/tv/imedit/epgdata.x create mode 100644 pkg/images/tv/imedit/epgsfit.x create mode 100644 pkg/images/tv/imedit/epimcopy.x create mode 100644 pkg/images/tv/imedit/epinput.x create mode 100644 pkg/images/tv/imedit/epix.h create mode 100644 pkg/images/tv/imedit/epline.x create mode 100644 pkg/images/tv/imedit/epmask.x create mode 100644 pkg/images/tv/imedit/epmove.x create mode 100644 pkg/images/tv/imedit/epnoise.x create mode 100644 pkg/images/tv/imedit/epreplace.gx create mode 100644 pkg/images/tv/imedit/epreplace.x create mode 100644 pkg/images/tv/imedit/epsearch.x create mode 100644 pkg/images/tv/imedit/epsetpars.x create mode 100644 pkg/images/tv/imedit/epstatistics.x create mode 100644 pkg/images/tv/imedit/epsurface.x create mode 100644 pkg/images/tv/imedit/imedit.key create mode 100644 pkg/images/tv/imedit/mkpkg create mode 100644 pkg/images/tv/imedit/t_imedit.x create mode 100644 pkg/images/tv/imexamine.par create mode 100644 pkg/images/tv/imexamine/iecimexam.x create mode 100644 pkg/images/tv/imexamine/iecolon.x create mode 100644 pkg/images/tv/imexamine/iedisplay.x create mode 100644 pkg/images/tv/imexamine/ieeimexam.x create mode 100644 pkg/images/tv/imexamine/iegcur.x create mode 100644 pkg/images/tv/imexamine/iegdata.x create mode 100644 pkg/images/tv/imexamine/iegimage.x create mode 100644 pkg/images/tv/imexamine/iegnfr.x create mode 100644 pkg/images/tv/imexamine/iegraph.x create mode 100644 pkg/images/tv/imexamine/iehimexam.x create mode 100644 pkg/images/tv/imexamine/ieimname.x create mode 100644 pkg/images/tv/imexamine/iejimexam.x create mode 100644 pkg/images/tv/imexamine/ielimexam.x create mode 100644 pkg/images/tv/imexamine/iemw.x create mode 100644 pkg/images/tv/imexamine/ieopenlog.x create mode 100644 pkg/images/tv/imexamine/iepos.x create mode 100644 pkg/images/tv/imexamine/ieprint.x create mode 100644 pkg/images/tv/imexamine/ieqrimexam.x create mode 100644 pkg/images/tv/imexamine/ierimexam.x create mode 100644 pkg/images/tv/imexamine/iesimexam.x create mode 100644 pkg/images/tv/imexamine/iestatistics.x create mode 100644 pkg/images/tv/imexamine/ietimexam.x create mode 100644 pkg/images/tv/imexamine/ievimexam.x create mode 100644 pkg/images/tv/imexamine/imexam.h create mode 100644 pkg/images/tv/imexamine/imexamine.par create mode 100644 pkg/images/tv/imexamine/mkpkg create mode 100644 pkg/images/tv/imexamine/starfocus.h create mode 100644 pkg/images/tv/imexamine/stfmeasure.x create mode 100644 pkg/images/tv/imexamine/stfprofile.x create mode 100644 pkg/images/tv/imexamine/t_imexam.x create mode 100644 pkg/images/tv/imexamine/x_imexam.x create mode 100644 pkg/images/tv/jimexam.par create mode 100644 pkg/images/tv/kimexam.par create mode 100644 pkg/images/tv/limexam.par create mode 100644 pkg/images/tv/mkpkg create mode 100644 pkg/images/tv/rimexam.par create mode 100644 pkg/images/tv/simexam.par create mode 100644 pkg/images/tv/tv.cl create mode 100644 pkg/images/tv/tv.hd create mode 100644 pkg/images/tv/tv.men create mode 100644 pkg/images/tv/tv.par create mode 100644 pkg/images/tv/tvmark.par create mode 100644 pkg/images/tv/tvmark/asciilook.inc create mode 100644 pkg/images/tv/tvmark/mkbmark.x create mode 100644 pkg/images/tv/tvmark/mkcolon.x create mode 100644 pkg/images/tv/tvmark/mkfind.x create mode 100644 pkg/images/tv/tvmark/mkgmarks.x create mode 100644 pkg/images/tv/tvmark/mkgpars.x create mode 100644 pkg/images/tv/tvmark/mkgscur.x create mode 100644 pkg/images/tv/tvmark/mkmag.x create mode 100644 pkg/images/tv/tvmark/mkmark.x create mode 100644 pkg/images/tv/tvmark/mknew.x create mode 100644 pkg/images/tv/tvmark/mkonemark.x create mode 100644 pkg/images/tv/tvmark/mkoutname.x create mode 100644 pkg/images/tv/tvmark/mkpkg create mode 100644 pkg/images/tv/tvmark/mkppars.x create mode 100644 pkg/images/tv/tvmark/mkremove.x create mode 100644 pkg/images/tv/tvmark/mkshow.x create mode 100644 pkg/images/tv/tvmark/mktext.x create mode 100644 pkg/images/tv/tvmark/mktools.x create mode 100644 pkg/images/tv/tvmark/pixelfont.inc create mode 100644 pkg/images/tv/tvmark/t_tvmark.x create mode 100644 pkg/images/tv/tvmark/tvmark.h create mode 100644 pkg/images/tv/vimexam.par create mode 100644 pkg/images/tv/wcslab.par create mode 100644 pkg/images/tv/wcslab/mkpkg create mode 100644 pkg/images/tv/wcslab/t_wcslab.x create mode 100644 pkg/images/tv/wcslab/wcs_desc.h create mode 100644 pkg/images/tv/wcslab/wcslab.h create mode 100644 pkg/images/tv/wcslab/wcslab.x create mode 100644 pkg/images/tv/wcslab/wlgrid.x create mode 100644 pkg/images/tv/wcslab/wllabel.x create mode 100644 pkg/images/tv/wcslab/wlsetup.x create mode 100644 pkg/images/tv/wcslab/wlutil.x create mode 100644 pkg/images/tv/wcslab/wlwcslab.x create mode 100644 pkg/images/tv/wcslab/zz.x create mode 100644 pkg/images/tv/wcspars.par create mode 100644 pkg/images/tv/wlpars.par create mode 100644 pkg/images/tv/x_tv.x create mode 100644 pkg/images/x_images.x create mode 100644 pkg/language/doc/access.hlp create mode 100644 pkg/language/doc/back.hlp create mode 100644 pkg/language/doc/beep.hlp create mode 100644 pkg/language/doc/break.hlp create mode 100644 pkg/language/doc/bye.hlp create mode 100644 pkg/language/doc/cache.hlp create mode 100644 pkg/language/doc/chdir.hlp create mode 100644 pkg/language/doc/cl.hlp create mode 100644 pkg/language/doc/clear.hlp create mode 100644 pkg/language/doc/commands.hlp create mode 100644 pkg/language/doc/cursors.hlp create mode 100644 pkg/language/doc/decls.hlp create mode 100644 pkg/language/doc/defpac.hlp create mode 100644 pkg/language/doc/dparam.hlp create mode 100644 pkg/language/doc/edit.hlp create mode 100644 pkg/language/doc/ehistory.hlp create mode 100644 pkg/language/doc/envget.hlp create mode 100644 pkg/language/doc/eparam.hlp create mode 100644 pkg/language/doc/error.hlp create mode 100644 pkg/language/doc/flprcache.hlp create mode 100644 pkg/language/doc/for.hlp create mode 100644 pkg/language/doc/fprint.hlp create mode 100644 pkg/language/doc/gflush.hlp create mode 100644 pkg/language/doc/goto.hlp create mode 100644 pkg/language/doc/hidetask.hlp create mode 100644 pkg/language/doc/history.hlp create mode 100644 pkg/language/doc/if.hlp create mode 100644 pkg/language/doc/imaccess.hlp create mode 100644 pkg/language/doc/intro.hlp create mode 100644 pkg/language/doc/isindef.hlp create mode 100644 pkg/language/doc/jobs.hlp create mode 100644 pkg/language/doc/keep.hlp create mode 100644 pkg/language/doc/kill.hlp create mode 100644 pkg/language/doc/logging.hlp create mode 100644 pkg/language/doc/logout.hlp create mode 100644 pkg/language/doc/lparam.hlp create mode 100644 pkg/language/doc/mathfcns.hlp create mode 100644 pkg/language/doc/mktemp.hlp create mode 100644 pkg/language/doc/next.hlp create mode 100644 pkg/language/doc/osfn.hlp create mode 100644 pkg/language/doc/package.hlp create mode 100644 pkg/language/doc/params.hlp create mode 100644 pkg/language/doc/prcache.hlp create mode 100644 pkg/language/doc/proc.hlp create mode 100644 pkg/language/doc/putlog.hlp create mode 100644 pkg/language/doc/radix.hlp create mode 100644 pkg/language/doc/return.hlp create mode 100644 pkg/language/doc/scan.hlp create mode 100644 pkg/language/doc/service.hlp create mode 100644 pkg/language/doc/set.hlp create mode 100644 pkg/language/doc/show.hlp create mode 100644 pkg/language/doc/sleep.hlp create mode 100644 pkg/language/doc/strings.hlp create mode 100644 pkg/language/doc/stty.hlp create mode 100644 pkg/language/doc/switch.hlp create mode 100644 pkg/language/doc/task.hlp create mode 100644 pkg/language/doc/time.hlp create mode 100644 pkg/language/doc/unlearn.hlp create mode 100644 pkg/language/doc/update.hlp create mode 100644 pkg/language/doc/wait.hlp create mode 100644 pkg/language/doc/which.hlp create mode 100644 pkg/language/doc/while.hlp create mode 100644 pkg/language/language.hd create mode 100644 pkg/language/language.men create mode 100644 pkg/language/language.par create mode 100644 pkg/lists/README create mode 100644 pkg/lists/Revisions create mode 100644 pkg/lists/average.cl create mode 100644 pkg/lists/average.par create mode 100644 pkg/lists/columns.par create mode 100644 pkg/lists/columns.x create mode 100644 pkg/lists/doc/Lcalc.hlp create mode 100644 pkg/lists/doc/Lintran.spc.hlp create mode 100644 pkg/lists/doc/Lists.hlp create mode 100644 pkg/lists/doc/average.hlp create mode 100644 pkg/lists/doc/columns.hlp create mode 100644 pkg/lists/doc/lintran.hlp create mode 100644 pkg/lists/doc/raverage.hlp create mode 100644 pkg/lists/doc/rgcursor.hlp create mode 100644 pkg/lists/doc/rimcursor.hlp create mode 100644 pkg/lists/doc/table.hlp create mode 100644 pkg/lists/doc/tokens.hlp create mode 100644 pkg/lists/doc/unique.hlp create mode 100644 pkg/lists/doc/words.hlp create mode 100644 pkg/lists/filter.cl create mode 100644 pkg/lists/lintran.par create mode 100644 pkg/lists/lintran.x create mode 100644 pkg/lists/lists.cl create mode 100644 pkg/lists/lists.hd create mode 100644 pkg/lists/lists.men create mode 100644 pkg/lists/lists.par create mode 100644 pkg/lists/mkpkg create mode 100644 pkg/lists/raverage.cl create mode 100644 pkg/lists/rgcursor.x create mode 100644 pkg/lists/rimcursor.par create mode 100644 pkg/lists/rimcursor.x create mode 100644 pkg/lists/table.par create mode 100644 pkg/lists/table.x create mode 100644 pkg/lists/tokens.par create mode 100644 pkg/lists/tokens.x create mode 100644 pkg/lists/unique.par create mode 100644 pkg/lists/unique.x create mode 100644 pkg/lists/words.par create mode 100644 pkg/lists/words.x create mode 100644 pkg/lists/x_lists.x create mode 100644 pkg/mkpkg create mode 100644 pkg/obsolete/Revisions create mode 100644 pkg/obsolete/doc/imtitle.hlp create mode 100644 pkg/obsolete/doc/mkhistogram.hlp create mode 100644 pkg/obsolete/doc/ofixpix.hlp create mode 100644 pkg/obsolete/doc/oimcombine.hlp create mode 100644 pkg/obsolete/doc/oimstat.hlp create mode 100644 pkg/obsolete/doc/orfits.hlp create mode 100644 pkg/obsolete/doc/owfits.hlp create mode 100644 pkg/obsolete/doc/radplt.hlp create mode 100644 pkg/obsolete/fits/README create mode 100644 pkg/obsolete/fits/fits_cards.x create mode 100644 pkg/obsolete/fits/fits_params.x create mode 100644 pkg/obsolete/fits/fits_read.x create mode 100644 pkg/obsolete/fits/fits_rheader.x create mode 100644 pkg/obsolete/fits/fits_rimage.x create mode 100644 pkg/obsolete/fits/fits_rpixels.x create mode 100644 pkg/obsolete/fits/fits_wheader.x create mode 100644 pkg/obsolete/fits/fits_wimage.x create mode 100644 pkg/obsolete/fits/fits_wpixels.x create mode 100644 pkg/obsolete/fits/fits_write.x create mode 100644 pkg/obsolete/fits/mkpkg create mode 100644 pkg/obsolete/fits/ranges.x create mode 100644 pkg/obsolete/fits/rfits.com create mode 100644 pkg/obsolete/fits/rfits.h create mode 100644 pkg/obsolete/fits/structure.hlp create mode 100644 pkg/obsolete/fits/t_rfits.x create mode 100644 pkg/obsolete/fits/t_wfits.x create mode 100644 pkg/obsolete/fits/wfits.com create mode 100644 pkg/obsolete/fits/wfits.h create mode 100644 pkg/obsolete/fixcol.gx create mode 100644 pkg/obsolete/fixcol.x create mode 100644 pkg/obsolete/fixline.gx create mode 100644 pkg/obsolete/fixline.x create mode 100644 pkg/obsolete/generic/fixcol.x create mode 100644 pkg/obsolete/generic/fixline.x create mode 100644 pkg/obsolete/generic/mkpkg create mode 100644 pkg/obsolete/imcombine/generic/icaclip.x create mode 100644 pkg/obsolete/imcombine/generic/icaverage.x create mode 100644 pkg/obsolete/imcombine/generic/iccclip.x create mode 100644 pkg/obsolete/imcombine/generic/icgdata.x create mode 100644 pkg/obsolete/imcombine/generic/icgrow.x create mode 100644 pkg/obsolete/imcombine/generic/icmedian.x create mode 100644 pkg/obsolete/imcombine/generic/icmm.x create mode 100644 pkg/obsolete/imcombine/generic/icombine.x create mode 100644 pkg/obsolete/imcombine/generic/icpclip.x create mode 100644 pkg/obsolete/imcombine/generic/icsclip.x create mode 100644 pkg/obsolete/imcombine/generic/icsigma.x create mode 100644 pkg/obsolete/imcombine/generic/icsort.x create mode 100644 pkg/obsolete/imcombine/generic/icstat.x create mode 100644 pkg/obsolete/imcombine/generic/mkpkg create mode 100644 pkg/obsolete/imcombine/icaclip.gx create mode 100644 pkg/obsolete/imcombine/icaverage.gx create mode 100644 pkg/obsolete/imcombine/iccclip.gx create mode 100644 pkg/obsolete/imcombine/icgdata.gx create mode 100644 pkg/obsolete/imcombine/icgrow.gx create mode 100644 pkg/obsolete/imcombine/icimstack.x create mode 100644 pkg/obsolete/imcombine/iclog.x create mode 100644 pkg/obsolete/imcombine/icmask.com create mode 100644 pkg/obsolete/imcombine/icmask.x create mode 100644 pkg/obsolete/imcombine/icmedian.gx create mode 100644 pkg/obsolete/imcombine/icmm.gx create mode 100644 pkg/obsolete/imcombine/icombine.com create mode 100644 pkg/obsolete/imcombine/icombine.gx create mode 100644 pkg/obsolete/imcombine/icombine.h create mode 100644 pkg/obsolete/imcombine/icpclip.gx create mode 100644 pkg/obsolete/imcombine/icrmasks.x create mode 100644 pkg/obsolete/imcombine/icscale.x create mode 100644 pkg/obsolete/imcombine/icsclip.gx create mode 100644 pkg/obsolete/imcombine/icsection.x create mode 100644 pkg/obsolete/imcombine/icsetout.x create mode 100644 pkg/obsolete/imcombine/icsigma.gx create mode 100644 pkg/obsolete/imcombine/icsort.gx create mode 100644 pkg/obsolete/imcombine/icstat.gx create mode 100644 pkg/obsolete/imcombine/mkpkg create mode 100644 pkg/obsolete/imcombine/t_imcombine.x create mode 100644 pkg/obsolete/imtitle.par create mode 100644 pkg/obsolete/mkhistogram.par create mode 100644 pkg/obsolete/mkpkg create mode 100644 pkg/obsolete/obsolete.cl create mode 100644 pkg/obsolete/obsolete.hd create mode 100644 pkg/obsolete/obsolete.men create mode 100644 pkg/obsolete/obsolete.par create mode 100644 pkg/obsolete/ofixpix.par create mode 100644 pkg/obsolete/oimcombine.par create mode 100644 pkg/obsolete/oimstat.h create mode 100644 pkg/obsolete/oimstatistics.par create mode 100644 pkg/obsolete/orfits.par create mode 100644 pkg/obsolete/owfits.par create mode 100644 pkg/obsolete/radplt.par create mode 100644 pkg/obsolete/t_fixpix.x create mode 100644 pkg/obsolete/t_imtitle.x create mode 100644 pkg/obsolete/t_mkhgm.x create mode 100644 pkg/obsolete/t_oimstat.x create mode 100644 pkg/obsolete/t_radplt.x create mode 100644 pkg/obsolete/x_obsolete.x create mode 100644 pkg/plot/README create mode 100644 pkg/plot/Revisions create mode 100644 pkg/plot/calcomp.par create mode 100644 pkg/plot/contour.par create mode 100644 pkg/plot/crtpict.par create mode 100644 pkg/plot/crtpict/calchgms.x create mode 100644 pkg/plot/crtpict/crtpict.h create mode 100644 pkg/plot/crtpict/crtpict.semi create mode 100644 pkg/plot/crtpict/crtulut.x create mode 100644 pkg/plot/crtpict/drawgraph.x create mode 100644 pkg/plot/crtpict/drawgrey.x create mode 100644 pkg/plot/crtpict/mapimage.x create mode 100644 pkg/plot/crtpict/minmax.x create mode 100644 pkg/plot/crtpict/mkpkg create mode 100644 pkg/plot/crtpict/plothgms.x create mode 100644 pkg/plot/crtpict/plotimage.x create mode 100644 pkg/plot/crtpict/setxform.x create mode 100644 pkg/plot/crtpict/sigl2.x create mode 100644 pkg/plot/crtpict/t_crtpict.x create mode 100644 pkg/plot/crtpict/tweakndc.x create mode 100644 pkg/plot/crtpict/wdes.h create mode 100644 pkg/plot/crtpict/xformimage.x create mode 100644 pkg/plot/crtpict/xyscale.x create mode 100644 pkg/plot/crtpict/zscale.x create mode 100644 pkg/plot/doc/calcomp.hlp create mode 100644 pkg/plot/doc/contour.hlp create mode 100644 pkg/plot/doc/crtpict.hlp create mode 100644 pkg/plot/doc/gdevices.hlp create mode 100644 pkg/plot/doc/gkidecode.hlp create mode 100644 pkg/plot/doc/gkidir.hlp create mode 100644 pkg/plot/doc/gkiextract.hlp create mode 100644 pkg/plot/doc/gkimosaic.hlp create mode 100644 pkg/plot/doc/graph.hlp create mode 100644 pkg/plot/doc/hafton.hlp create mode 100644 pkg/plot/doc/imdkern.hlp create mode 100644 pkg/plot/doc/implot.hlp create mode 100644 pkg/plot/doc/nsppkern.hlp create mode 100644 pkg/plot/doc/pcol.hlp create mode 100644 pkg/plot/doc/pcols.hlp create mode 100644 pkg/plot/doc/phistogram.hlp create mode 100644 pkg/plot/doc/pradprof.hlp create mode 100644 pkg/plot/doc/prow.hlp create mode 100644 pkg/plot/doc/prows.hlp create mode 100644 pkg/plot/doc/pvector.hlp create mode 100644 pkg/plot/doc/sgidecode.hlp create mode 100644 pkg/plot/doc/sgikern.hlp create mode 100644 pkg/plot/doc/showcap.hlp create mode 100644 pkg/plot/doc/stdgraph.hlp create mode 100644 pkg/plot/doc/stdplot.hlp create mode 100644 pkg/plot/doc/surface.hlp create mode 100644 pkg/plot/doc/velvect.hlp create mode 100644 pkg/plot/gdevices.par create mode 100644 pkg/plot/gdevices.x create mode 100644 pkg/plot/getdata.x create mode 100644 pkg/plot/gkidecode.par create mode 100644 pkg/plot/gkidir.par create mode 100644 pkg/plot/gkiextract.par create mode 100644 pkg/plot/gkimosaic.par create mode 100644 pkg/plot/graph.par create mode 100644 pkg/plot/hafton.par create mode 100644 pkg/plot/hgpline.x create mode 100644 pkg/plot/imdkern.par create mode 100644 pkg/plot/implot.par create mode 100644 pkg/plot/impprofile.x create mode 100644 pkg/plot/improject.x create mode 100644 pkg/plot/impstatus.x create mode 100644 pkg/plot/initmarker.x create mode 100644 pkg/plot/mkpkg create mode 100644 pkg/plot/nsppkern.par create mode 100644 pkg/plot/pcol.par create mode 100644 pkg/plot/pcols.par create mode 100644 pkg/plot/perim.x create mode 100644 pkg/plot/phistogram.par create mode 100644 pkg/plot/phistogram.x create mode 100644 pkg/plot/phminmax.x create mode 100644 pkg/plot/plot.cl create mode 100644 pkg/plot/plot.hd create mode 100644 pkg/plot/plot.men create mode 100644 pkg/plot/plot.par create mode 100644 pkg/plot/pltwcs.x create mode 100644 pkg/plot/pradprof.par create mode 100644 pkg/plot/prow.par create mode 100644 pkg/plot/prows.par create mode 100644 pkg/plot/pvector.par create mode 100644 pkg/plot/sgidecode.par create mode 100644 pkg/plot/sgikern.par create mode 100644 pkg/plot/stdgraph.par create mode 100644 pkg/plot/stdplot.par create mode 100644 pkg/plot/surface.par create mode 100644 pkg/plot/t_contour.x create mode 100644 pkg/plot/t_gkidir.x create mode 100644 pkg/plot/t_gkimos.x create mode 100644 pkg/plot/t_gkixt.x create mode 100644 pkg/plot/t_graph.x create mode 100644 pkg/plot/t_hafton.x create mode 100644 pkg/plot/t_implot.x create mode 100644 pkg/plot/t_pcol.x create mode 100644 pkg/plot/t_pcols.x create mode 100644 pkg/plot/t_pradprof.x create mode 100644 pkg/plot/t_prow.x create mode 100644 pkg/plot/t_prows.x create mode 100644 pkg/plot/t_pvector.x create mode 100644 pkg/plot/t_surface.x create mode 100644 pkg/plot/t_velvect.x create mode 100644 pkg/plot/velvect.par create mode 100644 pkg/plot/vport.x create mode 100644 pkg/plot/x_ncar.x create mode 100644 pkg/plot/x_plot.x create mode 100644 pkg/proto/README create mode 100644 pkg/proto/Revisions create mode 100644 pkg/proto/binfil.par create mode 100644 pkg/proto/bscale.par create mode 100644 pkg/proto/color/README create mode 100644 pkg/proto/color/Revisions create mode 100644 pkg/proto/color/color.cl create mode 100644 pkg/proto/color/color.hd create mode 100644 pkg/proto/color/color.men create mode 100644 pkg/proto/color/color.par create mode 100644 pkg/proto/color/color.readme create mode 100644 pkg/proto/color/doc/color.hlp create mode 100644 pkg/proto/color/doc/rgbdisplay.hlp create mode 100644 pkg/proto/color/doc/rgbdither.hlp create mode 100644 pkg/proto/color/doc/rgbsun.hlp create mode 100644 pkg/proto/color/doc/rgbto8.hlp create mode 100644 pkg/proto/color/lib/helpdb.mip create mode 100644 pkg/proto/color/lib/imtoolrgb.lut create mode 100644 pkg/proto/color/lib/mkpkg.inc create mode 100644 pkg/proto/color/lib/mkpkg.sf.SUN3 create mode 100644 pkg/proto/color/lib/root.hd create mode 100644 pkg/proto/color/lib/rootcolor.hd create mode 100644 pkg/proto/color/lib/saorgb.lut create mode 100644 pkg/proto/color/lib/strip.color create mode 100644 pkg/proto/color/lib/zzsetenv.def create mode 100644 pkg/proto/color/mkpkg create mode 100644 pkg/proto/color/src/mkpkg create mode 100644 pkg/proto/color/src/rgbdisplay.cl create mode 100644 pkg/proto/color/src/rgbdisplay.par create mode 100644 pkg/proto/color/src/rgbdither.par create mode 100644 pkg/proto/color/src/rgbsun.par create mode 100644 pkg/proto/color/src/rgbto8.par create mode 100644 pkg/proto/color/src/t_rgbdither.x create mode 100644 pkg/proto/color/src/t_rgbsun.x create mode 100644 pkg/proto/color/src/t_rgbto8.x create mode 100644 pkg/proto/color/src/x_color.x create mode 100644 pkg/proto/doc/binfil.hlp create mode 100644 pkg/proto/doc/bscale.hlp create mode 100644 pkg/proto/doc/epix.hlp create mode 100644 pkg/proto/doc/fields.hlp create mode 100644 pkg/proto/doc/fixpix.hlp create mode 100644 pkg/proto/doc/hfix.hlp create mode 100644 pkg/proto/doc/imalign.hlp create mode 100644 pkg/proto/doc/imcentroid.hlp create mode 100644 pkg/proto/doc/imcntr.hlp create mode 100644 pkg/proto/doc/imextensions.hlp create mode 100644 pkg/proto/doc/imfunction.hlp create mode 100644 pkg/proto/doc/imreplace.hlp create mode 100644 pkg/proto/doc/imscale.hlp create mode 100644 pkg/proto/doc/interp.hlp create mode 100644 pkg/proto/doc/irafil.hlp create mode 100644 pkg/proto/doc/joinlines.hlp create mode 100644 pkg/proto/doc/mimstat.hlp create mode 100644 pkg/proto/doc/mkglbhdr.hlp create mode 100644 pkg/proto/doc/mskexpr.hlp create mode 100644 pkg/proto/doc/mskregions.hlp create mode 100644 pkg/proto/doc/ringavg.hlp create mode 100644 pkg/proto/doc/rskysub.hlp create mode 100644 pkg/proto/doc/suntoiraf.hlp create mode 100644 pkg/proto/doc/text2mask.hlp create mode 100644 pkg/proto/doc/wcsedit.hlp create mode 100644 pkg/proto/doc/wcsreset.hlp create mode 100644 pkg/proto/epix.par create mode 100644 pkg/proto/epix.x create mode 100644 pkg/proto/fields.par create mode 100644 pkg/proto/fields.x create mode 100644 pkg/proto/fixpix.par create mode 100644 pkg/proto/hfix.par create mode 100644 pkg/proto/imcntr.par create mode 100644 pkg/proto/imextensions.par create mode 100644 pkg/proto/imscale.par create mode 100644 pkg/proto/interp.par create mode 100644 pkg/proto/interp.x create mode 100644 pkg/proto/intrp.f create mode 100644 pkg/proto/irafil.par create mode 100644 pkg/proto/joinlines.par create mode 100644 pkg/proto/maskexpr/gettok.h create mode 100644 pkg/proto/maskexpr/gettok.x create mode 100644 pkg/proto/maskexpr/megeom.x create mode 100644 pkg/proto/maskexpr/megsym.x create mode 100644 pkg/proto/maskexpr/memkmask.x create mode 100644 pkg/proto/maskexpr/meregfuncs.x create mode 100644 pkg/proto/maskexpr/meregmask.x create mode 100644 pkg/proto/maskexpr/mesetexpr.x create mode 100644 pkg/proto/maskexpr/mesetreg.x create mode 100644 pkg/proto/maskexpr/mkpkg create mode 100644 pkg/proto/maskexpr/mskexpand.x create mode 100644 pkg/proto/maskexpr/peregfuncs.h create mode 100644 pkg/proto/maskexpr/peregfuncs.x create mode 100644 pkg/proto/maskexpr/peregufcn.x create mode 100644 pkg/proto/maskexpr/t_mskexpr.x create mode 100644 pkg/proto/maskexpr/t_mskregions.x create mode 100644 pkg/proto/masks/mimstat.h create mode 100644 pkg/proto/masks/mimstat.x create mode 100644 pkg/proto/masks/mkpkg create mode 100644 pkg/proto/masks/mptools.x create mode 100644 pkg/proto/masks/mstcache.x create mode 100644 pkg/proto/masks/rsfnames.x create mode 100644 pkg/proto/masks/rskysub.h create mode 100644 pkg/proto/masks/rsmean.x create mode 100644 pkg/proto/masks/rsmmean.x create mode 100644 pkg/proto/masks/rsreject.x create mode 100644 pkg/proto/masks/rsscache.x create mode 100644 pkg/proto/masks/rsstats.x create mode 100644 pkg/proto/masks/t_mimstat.x create mode 100644 pkg/proto/masks/t_mimstat.xBAK create mode 100644 pkg/proto/masks/t_rskysub.x create mode 100644 pkg/proto/mimstatistics.par create mode 100644 pkg/proto/mkglbhdr.par create mode 100644 pkg/proto/mkpkg create mode 100644 pkg/proto/mskexpr.par create mode 100644 pkg/proto/mskregions.par create mode 100644 pkg/proto/proto.cl create mode 100644 pkg/proto/proto.hd create mode 100644 pkg/proto/proto.men create mode 100644 pkg/proto/proto.par create mode 100644 pkg/proto/ringavg.cl create mode 100644 pkg/proto/rskysub.par create mode 100644 pkg/proto/suntoiraf.par create mode 100644 pkg/proto/t_binfil.x create mode 100644 pkg/proto/t_bscale.x create mode 100644 pkg/proto/t_fixpix.x create mode 100644 pkg/proto/t_hfix.x create mode 100644 pkg/proto/t_imcntr.x create mode 100644 pkg/proto/t_imext.x create mode 100644 pkg/proto/t_imscale.x create mode 100644 pkg/proto/t_joinlines.x create mode 100644 pkg/proto/t_mask2text.x create mode 100644 pkg/proto/t_mkglbhdr.x create mode 100644 pkg/proto/t_suntoiraf.x create mode 100644 pkg/proto/t_text2mask.x create mode 100644 pkg/proto/text2mask.par create mode 100644 pkg/proto/vol/README create mode 100644 pkg/proto/vol/README.install create mode 100644 pkg/proto/vol/Revisions create mode 100644 pkg/proto/vol/lib/helpdb.mip create mode 100644 pkg/proto/vol/lib/mkpkg.inc create mode 100644 pkg/proto/vol/lib/root.hd create mode 100644 pkg/proto/vol/lib/rootvol.hd create mode 100644 pkg/proto/vol/lib/strip.vol create mode 100644 pkg/proto/vol/lib/zzsetenv.def create mode 100644 pkg/proto/vol/mkpkg create mode 100644 pkg/proto/vol/src/doc/concept.hlp create mode 100644 pkg/proto/vol/src/doc/i2sun.hlp create mode 100644 pkg/proto/vol/src/doc/im3dtran.hlp create mode 100644 pkg/proto/vol/src/doc/imjoin.hlp create mode 100644 pkg/proto/vol/src/doc/proj.hlp create mode 100644 pkg/proto/vol/src/doc/pvol.hlp create mode 100644 pkg/proto/vol/src/doc/volumes.hlp create mode 100644 pkg/proto/vol/src/i2sun.par create mode 100644 pkg/proto/vol/src/i2sun/cnvimage.x create mode 100644 pkg/proto/vol/src/i2sun/i2sun.h create mode 100644 pkg/proto/vol/src/i2sun/mkpkg create mode 100644 pkg/proto/vol/src/i2sun/sigln.x create mode 100644 pkg/proto/vol/src/i2sun/t_i2sun.x create mode 100644 pkg/proto/vol/src/i2sun/trsetup.x create mode 100644 pkg/proto/vol/src/i2sun/trulut.x create mode 100644 pkg/proto/vol/src/i2sun/x_i2sun.x create mode 100644 pkg/proto/vol/src/im3dtran.par create mode 100644 pkg/proto/vol/src/im3dtran/mkpkg create mode 100644 pkg/proto/vol/src/im3dtran/t_im3dtran.x create mode 100644 pkg/proto/vol/src/im3dtran/txyz3.gx create mode 100644 pkg/proto/vol/src/im3dtran/txyz3.x create mode 100644 pkg/proto/vol/src/im3dtran/txzy3.gx create mode 100644 pkg/proto/vol/src/im3dtran/txzy3.x create mode 100644 pkg/proto/vol/src/im3dtran/tyxz3.gx create mode 100644 pkg/proto/vol/src/im3dtran/tyxz3.x create mode 100644 pkg/proto/vol/src/im3dtran/tyzx3.gx create mode 100644 pkg/proto/vol/src/im3dtran/tyzx3.x create mode 100644 pkg/proto/vol/src/im3dtran/tzxy3.gx create mode 100644 pkg/proto/vol/src/im3dtran/tzxy3.x create mode 100644 pkg/proto/vol/src/im3dtran/tzyx3.gx create mode 100644 pkg/proto/vol/src/im3dtran/tzyx3.x create mode 100644 pkg/proto/vol/src/im3dtran/x_im3dtran.x create mode 100644 pkg/proto/vol/src/imjoin.gx create mode 100644 pkg/proto/vol/src/imjoin.par create mode 100644 pkg/proto/vol/src/imjoin.x create mode 100644 pkg/proto/vol/src/imminmax.x create mode 100644 pkg/proto/vol/src/mkpkg create mode 100644 pkg/proto/vol/src/pv_gmem.x create mode 100644 pkg/proto/vol/src/pvol.h create mode 100644 pkg/proto/vol/src/pvol.par create mode 100644 pkg/proto/vol/src/t_imjoin.x create mode 100644 pkg/proto/vol/src/t_pvol.x create mode 100644 pkg/proto/vol/src/vgetincr.x create mode 100644 pkg/proto/vol/src/vmatrix.x create mode 100644 pkg/proto/vol/src/vproject.x create mode 100644 pkg/proto/vol/src/vtransmit.gx create mode 100644 pkg/proto/vol/src/vtransmit.x create mode 100644 pkg/proto/vol/src/x_vol.x create mode 100644 pkg/proto/vol/vol.cl create mode 100644 pkg/proto/vol/vol.hd create mode 100644 pkg/proto/vol/vol.men create mode 100644 pkg/proto/vol/vol.par create mode 100644 pkg/proto/x_proto.x create mode 100644 pkg/softools/README create mode 100644 pkg/softools/memchk.par create mode 100644 pkg/softools/memchk.x create mode 100644 pkg/softools/mkmanpage.cl create mode 100644 pkg/softools/mkmanpage.hlp create mode 100644 pkg/softools/mkmanpage.par create mode 100644 pkg/softools/mkpkg create mode 100644 pkg/softools/mktags.hlp create mode 100644 pkg/softools/mktags.par create mode 100644 pkg/softools/mktags.x create mode 100644 pkg/softools/mkttydata.hlp create mode 100644 pkg/softools/mkttydata.par create mode 100644 pkg/softools/softools.cl create mode 100644 pkg/softools/softools.hd create mode 100644 pkg/softools/softools.men create mode 100644 pkg/softools/softools.par create mode 100644 pkg/softools/tgutil.x create mode 100644 pkg/softools/x_softools.x create mode 100644 pkg/system/README create mode 100644 pkg/system/bench.cl create mode 100644 pkg/system/chkupdate.par create mode 100644 pkg/system/chkupdate.x create mode 100644 pkg/system/cmdstr.par create mode 100644 pkg/system/cmdstr.x create mode 100644 pkg/system/concatenate.par create mode 100644 pkg/system/concatenate.x create mode 100644 pkg/system/copy.par create mode 100644 pkg/system/copy.x create mode 100644 pkg/system/count.par create mode 100644 pkg/system/count.x create mode 100644 pkg/system/delete.par create mode 100644 pkg/system/delete.x create mode 100644 pkg/system/devices.cl create mode 100644 pkg/system/directory.par create mode 100644 pkg/system/directory.x create mode 100644 pkg/system/doc/Sys.hlp create mode 100644 pkg/system/doc/Sys_intro.hlp create mode 100644 pkg/system/doc/allocate.hlp create mode 100644 pkg/system/doc/bench.hlp create mode 100644 pkg/system/doc/chkupdate.hlp create mode 100644 pkg/system/doc/concatenate.hlp create mode 100644 pkg/system/doc/copy.hlp create mode 100644 pkg/system/doc/count.hlp create mode 100644 pkg/system/doc/deallocate.hlp create mode 100644 pkg/system/doc/delete.hlp create mode 100644 pkg/system/doc/devstatus.hlp create mode 100644 pkg/system/doc/directory.hlp create mode 100644 pkg/system/doc/diskspace.hlp create mode 100644 pkg/system/doc/fcache.hlp create mode 100644 pkg/system/doc/files.hlp create mode 100644 pkg/system/doc/gripes.hlp create mode 100644 pkg/system/doc/head.hlp create mode 100644 pkg/system/doc/help.hlp create mode 100644 pkg/system/doc/lprint.hlp create mode 100644 pkg/system/doc/match.hlp create mode 100644 pkg/system/doc/mkdir.hlp create mode 100644 pkg/system/doc/mkscript.hlp create mode 100644 pkg/system/doc/movefiles.hlp create mode 100644 pkg/system/doc/netstatus.hlp create mode 100644 pkg/system/doc/news.hlp create mode 100644 pkg/system/doc/page.hlp create mode 100644 pkg/system/doc/pathnames.hlp create mode 100644 pkg/system/doc/phelp.hlp create mode 100644 pkg/system/doc/protect.hlp create mode 100644 pkg/system/doc/references.hlp create mode 100644 pkg/system/doc/rename.hlp create mode 100644 pkg/system/doc/rewind.hlp create mode 100644 pkg/system/doc/sort.hlp create mode 100644 pkg/system/doc/spy.hlp create mode 100644 pkg/system/doc/tail.hlp create mode 100644 pkg/system/doc/tee.hlp create mode 100644 pkg/system/doc/touch.hlp create mode 100644 pkg/system/doc/type.hlp create mode 100644 pkg/system/doc/unprotect.hlp create mode 100644 pkg/system/doc/urlget.hlp create mode 100644 pkg/system/fcache.par create mode 100644 pkg/system/files.par create mode 100644 pkg/system/files.x create mode 100644 pkg/system/hdbexamine.par create mode 100644 pkg/system/head.par create mode 100644 pkg/system/head.x create mode 100644 pkg/system/help.par create mode 100644 pkg/system/help/README create mode 100644 pkg/system/help/design.hlp create mode 100644 pkg/system/help/filetemp.x create mode 100644 pkg/system/help/getoption.x create mode 100644 pkg/system/help/hbgetblk.x create mode 100644 pkg/system/help/hdbexamine.hlp create mode 100644 pkg/system/help/help.h create mode 100644 pkg/system/help/helpdb.x create mode 100644 pkg/system/help/helpdir.h create mode 100644 pkg/system/help/helpdir.x create mode 100644 pkg/system/help/hinput.x create mode 100644 pkg/system/help/houtput.x create mode 100644 pkg/system/help/lroff/breakline.o create mode 100644 pkg/system/help/lroff/breakline.x create mode 100644 pkg/system/help/lroff/center.o create mode 100644 pkg/system/help/lroff/center.x create mode 100644 pkg/system/help/lroff/dols.o create mode 100644 pkg/system/help/lroff/dols.x create mode 100644 pkg/system/help/lroff/getarg.o create mode 100644 pkg/system/help/lroff/getarg.x create mode 100644 pkg/system/help/lroff/indent.o create mode 100644 pkg/system/help/lroff/indent.x create mode 100644 pkg/system/help/lroff/input.o create mode 100644 pkg/system/help/lroff/input.x create mode 100644 pkg/system/help/lroff/justify.o create mode 100644 pkg/system/help/lroff/justify.x create mode 100644 pkg/system/help/lroff/lroff.com create mode 100644 pkg/system/help/lroff/lroff.h create mode 100644 pkg/system/help/lroff/lroff.hlp create mode 100644 pkg/system/help/lroff/lroff.o create mode 100644 pkg/system/help/lroff/lroff.x create mode 100644 pkg/system/help/lroff/lroff2html.c create mode 100644 pkg/system/help/lroff/lroff2html.x create mode 100644 pkg/system/help/lroff/lroff2ps.x create mode 100644 pkg/system/help/lroff/mkpkg create mode 100644 pkg/system/help/lroff/nextcmd.x create mode 100644 pkg/system/help/lroff/nofill.x create mode 100644 pkg/system/help/lroff/output.x create mode 100644 pkg/system/help/lroff/rawcopy.x create mode 100644 pkg/system/help/lroff/section.x create mode 100644 pkg/system/help/lroff/skiplines.x create mode 100644 pkg/system/help/lroff/textlen.x create mode 100644 pkg/system/help/lroff/textout.x create mode 100644 pkg/system/help/lroff/words.com create mode 100644 pkg/system/help/manout.x create mode 100644 pkg/system/help/mkhelpdb.hlp create mode 100644 pkg/system/help/mkpkg create mode 100644 pkg/system/help/modlist.x create mode 100644 pkg/system/help/modtemp.x create mode 100644 pkg/system/help/prblkhdr.x create mode 100644 pkg/system/help/prdir.x create mode 100644 pkg/system/help/prfile.x create mode 100644 pkg/system/help/prfnames.x create mode 100644 pkg/system/help/prhelp.x create mode 100644 pkg/system/help/prhlpblk.x create mode 100644 pkg/system/help/prmodname.x create mode 100644 pkg/system/help/prsummary.x create mode 100644 pkg/system/help/t_hdbexamine.x create mode 100644 pkg/system/help/t_help.x create mode 100644 pkg/system/help/t_lroff.x create mode 100644 pkg/system/help/t_mkhelpdb.x create mode 100644 pkg/system/help/tlist.x create mode 100644 pkg/system/help/xhelp/help.gui create mode 100644 pkg/system/help/xhelp/mkpkg create mode 100644 pkg/system/help/xhelp/xhcmds.x create mode 100644 pkg/system/help/xhelp/xhdir.x create mode 100644 pkg/system/help/xhelp/xhelp.h create mode 100644 pkg/system/help/xhelp/xhelp.x create mode 100644 pkg/system/help/xhelp/xhfiles.x create mode 100644 pkg/system/help/xhelp/xhhelp.x create mode 100644 pkg/system/help/xhelp/xhinit.x create mode 100644 pkg/system/help/xhelp/xhofile.x create mode 100644 pkg/system/help/xhelp/xhpkg.x create mode 100644 pkg/system/help/xhelp/xhprint.x create mode 100644 pkg/system/help/xhelp/xhqref.x create mode 100644 pkg/system/help/xhelp/xhroot.x create mode 100644 pkg/system/help/xhelp/xhsave.x create mode 100644 pkg/system/help/xhelp/xhsearch.x create mode 100644 pkg/system/help/xhelp/xhsort.x create mode 100644 pkg/system/help/xhelp/zzdebug.x create mode 100644 pkg/system/lprint.par create mode 100644 pkg/system/lprint.x create mode 100644 pkg/system/lroff.par create mode 100644 pkg/system/match.par create mode 100644 pkg/system/match.x create mode 100644 pkg/system/mkdir.par create mode 100644 pkg/system/mkdir.x create mode 100644 pkg/system/mkhelpdb.par create mode 100644 pkg/system/mkpkg create mode 100644 pkg/system/mkscript.cl create mode 100644 pkg/system/mkscript.par create mode 100644 pkg/system/movefiles.par create mode 100644 pkg/system/movefiles.x create mode 100644 pkg/system/mtclean.par create mode 100644 pkg/system/mtclean.x create mode 100644 pkg/system/netstatus.x create mode 100644 pkg/system/news.cl create mode 100644 pkg/system/page.par create mode 100644 pkg/system/page.x create mode 100644 pkg/system/pathnames.par create mode 100644 pkg/system/pathnames.x create mode 100644 pkg/system/phelp.cl create mode 100644 pkg/system/protect.par create mode 100644 pkg/system/protect.x create mode 100644 pkg/system/references.cl create mode 100644 pkg/system/rename.par create mode 100644 pkg/system/rename.x create mode 100644 pkg/system/rewind.par create mode 100644 pkg/system/rewind.x create mode 100644 pkg/system/sort.com create mode 100644 pkg/system/sort.par create mode 100644 pkg/system/sort.x create mode 100644 pkg/system/system.cl create mode 100644 pkg/system/system.hd create mode 100644 pkg/system/system.men create mode 100644 pkg/system/system.par create mode 100644 pkg/system/t_fcache.x create mode 100644 pkg/system/t_urlget.x create mode 100644 pkg/system/tail.par create mode 100644 pkg/system/tail.x create mode 100644 pkg/system/tee.par create mode 100644 pkg/system/tee.x create mode 100644 pkg/system/touch.par create mode 100644 pkg/system/touch.x create mode 100644 pkg/system/type.par create mode 100644 pkg/system/type.x create mode 100644 pkg/system/unprotect.par create mode 100644 pkg/system/unprotect.x create mode 100644 pkg/system/urlget.par create mode 100644 pkg/system/x_system.x create mode 100644 pkg/tbtables/README create mode 100644 pkg/tbtables/Revisions create mode 100644 pkg/tbtables/cfitsio/Licence.txt create mode 100644 pkg/tbtables/cfitsio/Makefile.in create mode 100644 pkg/tbtables/cfitsio/README create mode 100644 pkg/tbtables/cfitsio/README.MacOS create mode 100644 pkg/tbtables/cfitsio/buffers.c create mode 100644 pkg/tbtables/cfitsio/cfileio.c create mode 100644 pkg/tbtables/cfitsio/cfitsio.doc create mode 100644 pkg/tbtables/cfitsio/cfitsio.ps create mode 100644 pkg/tbtables/cfitsio/cfitsio.tex create mode 100644 pkg/tbtables/cfitsio/cfitsio.toc create mode 100644 pkg/tbtables/cfitsio/cfitsio_mac.sit.hqx create mode 100644 pkg/tbtables/cfitsio/cfortran.doc create mode 100644 pkg/tbtables/cfitsio/cfortran.h create mode 100644 pkg/tbtables/cfitsio/changes.txt create mode 100644 pkg/tbtables/cfitsio/checksum.c create mode 100644 pkg/tbtables/cfitsio/compress.c create mode 100644 pkg/tbtables/cfitsio/compress.h create mode 100755 pkg/tbtables/cfitsio/configure create mode 100644 pkg/tbtables/cfitsio/configure.in create mode 100644 pkg/tbtables/cfitsio/cookbook.c create mode 100644 pkg/tbtables/cfitsio/cookbook.f create mode 100644 pkg/tbtables/cfitsio/drvrfile.c create mode 100644 pkg/tbtables/cfitsio/drvrmem.c create mode 100644 pkg/tbtables/cfitsio/drvrnet.c create mode 100644 pkg/tbtables/cfitsio/drvrsmem.c create mode 100644 pkg/tbtables/cfitsio/drvrsmem.h create mode 100644 pkg/tbtables/cfitsio/editcol.c create mode 100644 pkg/tbtables/cfitsio/edithdu.c create mode 100644 pkg/tbtables/cfitsio/eval.l create mode 100644 pkg/tbtables/cfitsio/eval.y create mode 100644 pkg/tbtables/cfitsio/eval_defs.h create mode 100644 pkg/tbtables/cfitsio/eval_f.c create mode 100644 pkg/tbtables/cfitsio/eval_l.c create mode 100644 pkg/tbtables/cfitsio/eval_tab.h create mode 100644 pkg/tbtables/cfitsio/eval_y.c create mode 100644 pkg/tbtables/cfitsio/f77.inc create mode 100644 pkg/tbtables/cfitsio/f77_wrap.h create mode 100644 pkg/tbtables/cfitsio/f77_wrap1.c create mode 100644 pkg/tbtables/cfitsio/f77_wrap2.c create mode 100644 pkg/tbtables/cfitsio/fitscopy.c create mode 100644 pkg/tbtables/cfitsio/fitscore.c create mode 100644 pkg/tbtables/cfitsio/fitsio.doc create mode 100644 pkg/tbtables/cfitsio/fitsio.h create mode 100644 pkg/tbtables/cfitsio/fitsio.ps create mode 100644 pkg/tbtables/cfitsio/fitsio.tex create mode 100644 pkg/tbtables/cfitsio/fitsio.toc create mode 100644 pkg/tbtables/cfitsio/fitsio2.h create mode 100644 pkg/tbtables/cfitsio/getcol.c create mode 100644 pkg/tbtables/cfitsio/getcolb.c create mode 100644 pkg/tbtables/cfitsio/getcold.c create mode 100644 pkg/tbtables/cfitsio/getcole.c create mode 100644 pkg/tbtables/cfitsio/getcoli.c create mode 100644 pkg/tbtables/cfitsio/getcolj.c create mode 100644 pkg/tbtables/cfitsio/getcolk.c create mode 100644 pkg/tbtables/cfitsio/getcoll.c create mode 100644 pkg/tbtables/cfitsio/getcols.c create mode 100644 pkg/tbtables/cfitsio/getcolsb.c create mode 100644 pkg/tbtables/cfitsio/getcolui.c create mode 100644 pkg/tbtables/cfitsio/getcoluj.c create mode 100644 pkg/tbtables/cfitsio/getcoluk.c create mode 100644 pkg/tbtables/cfitsio/getkey.c create mode 100644 pkg/tbtables/cfitsio/group.c create mode 100644 pkg/tbtables/cfitsio/group.h create mode 100644 pkg/tbtables/cfitsio/grparser.c create mode 100644 pkg/tbtables/cfitsio/grparser.h create mode 100644 pkg/tbtables/cfitsio/histo.c create mode 100644 pkg/tbtables/cfitsio/imcompress.c create mode 100644 pkg/tbtables/cfitsio/iraffits.c create mode 100644 pkg/tbtables/cfitsio/iter_a.c create mode 100644 pkg/tbtables/cfitsio/iter_a.f create mode 100644 pkg/tbtables/cfitsio/iter_a.fit create mode 100644 pkg/tbtables/cfitsio/iter_b.c create mode 100644 pkg/tbtables/cfitsio/iter_b.f create mode 100644 pkg/tbtables/cfitsio/iter_b.fit create mode 100644 pkg/tbtables/cfitsio/iter_c.c create mode 100644 pkg/tbtables/cfitsio/iter_c.f create mode 100644 pkg/tbtables/cfitsio/iter_c.fit create mode 100644 pkg/tbtables/cfitsio/listhead.c create mode 100644 pkg/tbtables/cfitsio/longnam.h create mode 100644 pkg/tbtables/cfitsio/make_dfloat.com create mode 100644 pkg/tbtables/cfitsio/make_gfloat.com create mode 100644 pkg/tbtables/cfitsio/make_ieee.com create mode 100644 pkg/tbtables/cfitsio/makefile.bc create mode 100644 pkg/tbtables/cfitsio/makefile.os2 create mode 100644 pkg/tbtables/cfitsio/makefile.vcc create mode 100644 pkg/tbtables/cfitsio/makepc.bat create mode 100644 pkg/tbtables/cfitsio/mkpkg create mode 100644 pkg/tbtables/cfitsio/modkey.c create mode 100644 pkg/tbtables/cfitsio/pctype.h create mode 100644 pkg/tbtables/cfitsio/pliocomp.c create mode 100644 pkg/tbtables/cfitsio/putcol.c create mode 100644 pkg/tbtables/cfitsio/putcolb.c create mode 100644 pkg/tbtables/cfitsio/putcold.c create mode 100644 pkg/tbtables/cfitsio/putcole.c create mode 100644 pkg/tbtables/cfitsio/putcoli.c create mode 100644 pkg/tbtables/cfitsio/putcolj.c create mode 100644 pkg/tbtables/cfitsio/putcolk.c create mode 100644 pkg/tbtables/cfitsio/putcoll.c create mode 100644 pkg/tbtables/cfitsio/putcols.c create mode 100644 pkg/tbtables/cfitsio/putcolsb.c create mode 100644 pkg/tbtables/cfitsio/putcolu.c create mode 100644 pkg/tbtables/cfitsio/putcolui.c create mode 100644 pkg/tbtables/cfitsio/putcoluj.c create mode 100644 pkg/tbtables/cfitsio/putcoluk.c create mode 100644 pkg/tbtables/cfitsio/putkey.c create mode 100644 pkg/tbtables/cfitsio/quantize.c create mode 100644 pkg/tbtables/cfitsio/quick.ps create mode 100644 pkg/tbtables/cfitsio/quick.tex create mode 100644 pkg/tbtables/cfitsio/quick.toc create mode 100644 pkg/tbtables/cfitsio/region.c create mode 100644 pkg/tbtables/cfitsio/region.h create mode 100644 pkg/tbtables/cfitsio/ricecomp.c create mode 100644 pkg/tbtables/cfitsio/ricecomp.h create mode 100644 pkg/tbtables/cfitsio/sample.tpl create mode 100644 pkg/tbtables/cfitsio/scalnull.c create mode 100644 pkg/tbtables/cfitsio/smem.c create mode 100644 pkg/tbtables/cfitsio/speed.c create mode 100644 pkg/tbtables/cfitsio/swapproc.c create mode 100644 pkg/tbtables/cfitsio/testf77.f create mode 100644 pkg/tbtables/cfitsio/testf77.out create mode 100644 pkg/tbtables/cfitsio/testf77.std create mode 100644 pkg/tbtables/cfitsio/testprog.c create mode 100644 pkg/tbtables/cfitsio/testprog.out create mode 100644 pkg/tbtables/cfitsio/testprog.std create mode 100644 pkg/tbtables/cfitsio/testprog.tpt create mode 100644 pkg/tbtables/cfitsio/vmsieee.c create mode 100644 pkg/tbtables/cfitsio/vmsieeed.mar create mode 100644 pkg/tbtables/cfitsio/vmsieeer.mar create mode 100644 pkg/tbtables/cfitsio/wcssub.c create mode 100644 pkg/tbtables/cfitsio/wcsutil.c create mode 100644 pkg/tbtables/cfitsio/wcsutil.c.OLD create mode 100644 pkg/tbtables/cfitsio/winDumpExts.mak create mode 100644 pkg/tbtables/cfitsio/windumpexts.c create mode 100644 pkg/tbtables/doc/Notes create mode 100644 pkg/tbtables/doc/README create mode 100644 pkg/tbtables/doc/calls.doc create mode 100644 pkg/tbtables/doc/cfitsio.install create mode 100644 pkg/tbtables/doc/descrip.doc create mode 100644 pkg/tbtables/doc/ex.x create mode 100644 pkg/tbtables/doc/example.doc create mode 100644 pkg/tbtables/doc/fileformat.doc create mode 100644 pkg/tbtables/doc/tbtcpy.lis create mode 100644 pkg/tbtables/doc/text_tables.doc create mode 100644 pkg/tbtables/doc/versions.doc create mode 100644 pkg/tbtables/fitsio/README create mode 100644 pkg/tbtables/fitsio/fitsspp.com create mode 100644 pkg/tbtables/fitsio/fitsspp.x create mode 100644 pkg/tbtables/fitsio/fitssppb/README create mode 100644 pkg/tbtables/fitsio/fitssppb/fitsio.h create mode 100644 pkg/tbtables/fitsio/fitssppb/fsadef.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsarch.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsasfm.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsbdef.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsbnfm.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsclos.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fscmps.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fscmsg.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fscopy.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fscpdt.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fscrhd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsdcol.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsddef.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsdelt.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsdhdu.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsdkey.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsdrec.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsdrow.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsdsum.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsdtyp.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsesum.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsfiou.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsg2db.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsg2dd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsg2de.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsg2di.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsg2dj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsg3db.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsg3dd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsg3de.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsg3di.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsg3dj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgabc.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgacl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgbcl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcfb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcfc.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcfd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcfe.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcfi.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcfj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcfl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcfm.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcfs.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcks.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcnn.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcno.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcrd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcvb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcvc.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcvd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcve.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcvi.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcvj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcvm.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcvs.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcx.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcxd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcxi.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgcxj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgdes.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgerr.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsggpb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsggpd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsggpe.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsggpi.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsggpj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsghad.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsghbn.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsghdn.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsghpr.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsghps.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsghsp.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsghtb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgics.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgiou.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgkey.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgknd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgkne.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgknj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgknl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgkns.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgkyd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgkye.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgkyj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgkyl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgkyn.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgkys.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgkyt.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgmsg.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgpfb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgpfd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgpfe.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgpfi.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgpfj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgpvb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgpvd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgpve.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgpvi.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgpvj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgrec.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgrsz.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsdt.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsfb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsfd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsfe.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsfi.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsfj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsvb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsvd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsve.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsvi.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgsvj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgtbb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgtbs.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgtcl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgtcs.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgtdm.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsgthd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fshdef.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsibin.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsicol.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsiimg.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsikyd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsikye.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsikyf.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsikyg.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsikyj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsikyl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsikys.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsinit.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsirec.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsirow.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsitab.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fskeyn.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmahd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmcom.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmcrd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmkyd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmkye.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmkyf.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmkyg.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmkyj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmkyl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmkys.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmnam.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmrec.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsmrhd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsnkey.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsopen.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsp2db.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsp2dd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsp2de.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsp2di.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsp2dj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsp3db.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsp3dd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsp3de.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsp3di.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsp3dj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcks.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspclb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspclc.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcld.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcle.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcli.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspclj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcll.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspclm.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcls.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspclu.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspclx.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcnb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcnd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcne.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcni.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcnj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspcom.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspdat.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspdef.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspdes.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspgpb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspgpd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspgpe.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspgpi.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspgpj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsphbn.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsphis.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsphpr.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsphtb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkls.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspknd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkne.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspknf.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkng.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspknj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspknl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkns.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkyd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkye.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkyf.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkyg.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkyj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkyl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkys.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspkyt.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsplsw.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspmsg.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspnul.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsppnb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsppnd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsppne.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsppni.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsppnj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspprb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspprd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsppre.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsppri.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspprj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsppru.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsprec.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspscl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspssb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspssd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspsse.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspssi.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspssj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspsvc.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsptbb.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsptbs.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsptdm.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fspthp.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsrdef.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fssnul.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fstkey.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fstnul.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fstscl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsucks.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsucrd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsukyd.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsukye.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsukyf.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsukyg.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsukyj.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsukyl.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsukys.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsvcks.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsvers.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fswldp.x create mode 100644 pkg/tbtables/fitsio/fitssppb/fsxypx.x create mode 100644 pkg/tbtables/fitsio/fitssppb/mkpkg create mode 100644 pkg/tbtables/fitsio/ftadef.f create mode 100644 pkg/tbtables/fitsio/ftaini.f create mode 100644 pkg/tbtables/fitsio/ftarch.f create mode 100644 pkg/tbtables/fitsio/ftas2c.f create mode 100644 pkg/tbtables/fitsio/ftasfm.f create mode 100644 pkg/tbtables/fitsio/ftbdef.f create mode 100644 pkg/tbtables/fitsio/ftbini.f create mode 100644 pkg/tbtables/fitsio/ftbnfm.f create mode 100644 pkg/tbtables/fitsio/ftc2as.f create mode 100644 pkg/tbtables/fitsio/ftc2d.f create mode 100644 pkg/tbtables/fitsio/ftc2dd.f create mode 100644 pkg/tbtables/fitsio/ftc2i.f create mode 100644 pkg/tbtables/fitsio/ftc2ii.f create mode 100644 pkg/tbtables/fitsio/ftc2l.f create mode 100644 pkg/tbtables/fitsio/ftc2ll.f create mode 100644 pkg/tbtables/fitsio/ftc2r.f create mode 100644 pkg/tbtables/fitsio/ftc2rr.f create mode 100644 pkg/tbtables/fitsio/ftc2s.f create mode 100644 pkg/tbtables/fitsio/ftc2x.f create mode 100644 pkg/tbtables/fitsio/ftcdel.f create mode 100644 pkg/tbtables/fitsio/ftcdfl.f create mode 100644 pkg/tbtables/fitsio/ftchdu.f create mode 100644 pkg/tbtables/fitsio/ftchfl.f create mode 100644 pkg/tbtables/fitsio/ftcins.f create mode 100644 pkg/tbtables/fitsio/ftclos.f create mode 100644 pkg/tbtables/fitsio/ftcmps.f create mode 100644 pkg/tbtables/fitsio/ftcmsg.f create mode 100644 pkg/tbtables/fitsio/ftcopy.f create mode 100644 pkg/tbtables/fitsio/ftcpdt.f create mode 100644 pkg/tbtables/fitsio/ftcrep.f create mode 100644 pkg/tbtables/fitsio/ftcrhd.f create mode 100644 pkg/tbtables/fitsio/ftcsum.f create mode 100644 pkg/tbtables/fitsio/ftd2e.f create mode 100644 pkg/tbtables/fitsio/ftd2f.f create mode 100644 pkg/tbtables/fitsio/ftdblk.f create mode 100644 pkg/tbtables/fitsio/ftdcol.f create mode 100644 pkg/tbtables/fitsio/ftddef.f create mode 100644 pkg/tbtables/fitsio/ftdelt.f create mode 100644 pkg/tbtables/fitsio/ftdhdu.f create mode 100644 pkg/tbtables/fitsio/ftdkey.f create mode 100644 pkg/tbtables/fitsio/ftdrec.f create mode 100644 pkg/tbtables/fitsio/ftdrow.f create mode 100644 pkg/tbtables/fitsio/ftdsum.f create mode 100644 pkg/tbtables/fitsio/ftdtyp.f create mode 100644 pkg/tbtables/fitsio/ftesum.f create mode 100644 pkg/tbtables/fitsio/ftfiou.f create mode 100644 pkg/tbtables/fitsio/ftfrcl.f create mode 100644 pkg/tbtables/fitsio/ftg2db.f create mode 100644 pkg/tbtables/fitsio/ftg2dd.f create mode 100644 pkg/tbtables/fitsio/ftg2de.f create mode 100644 pkg/tbtables/fitsio/ftg2di.f create mode 100644 pkg/tbtables/fitsio/ftg2dj.f create mode 100644 pkg/tbtables/fitsio/ftg3db.f create mode 100644 pkg/tbtables/fitsio/ftg3dd.f create mode 100644 pkg/tbtables/fitsio/ftg3de.f create mode 100644 pkg/tbtables/fitsio/ftg3di.f create mode 100644 pkg/tbtables/fitsio/ftg3dj.f create mode 100644 pkg/tbtables/fitsio/ftgabc.f create mode 100644 pkg/tbtables/fitsio/ftgacl.f create mode 100644 pkg/tbtables/fitsio/ftgatp.f create mode 100644 pkg/tbtables/fitsio/ftgbcl.f create mode 100644 pkg/tbtables/fitsio/ftgbit.f create mode 100644 pkg/tbtables/fitsio/ftgbnh.f create mode 100644 pkg/tbtables/fitsio/ftgbtp.f create mode 100644 pkg/tbtables/fitsio/ftgcfb.f create mode 100644 pkg/tbtables/fitsio/ftgcfc.f create mode 100644 pkg/tbtables/fitsio/ftgcfd.f create mode 100644 pkg/tbtables/fitsio/ftgcfe.f create mode 100644 pkg/tbtables/fitsio/ftgcfi.f create mode 100644 pkg/tbtables/fitsio/ftgcfj.f create mode 100644 pkg/tbtables/fitsio/ftgcfl.f create mode 100644 pkg/tbtables/fitsio/ftgcfm.f create mode 100644 pkg/tbtables/fitsio/ftgcfs.f create mode 100644 pkg/tbtables/fitsio/ftgcks.f create mode 100644 pkg/tbtables/fitsio/ftgcl.f create mode 100644 pkg/tbtables/fitsio/ftgclb.f create mode 100644 pkg/tbtables/fitsio/ftgclc.f create mode 100644 pkg/tbtables/fitsio/ftgcld.f create mode 100644 pkg/tbtables/fitsio/ftgcle.f create mode 100644 pkg/tbtables/fitsio/ftgcli.f create mode 100644 pkg/tbtables/fitsio/ftgclj.f create mode 100644 pkg/tbtables/fitsio/ftgclm.f create mode 100644 pkg/tbtables/fitsio/ftgcls.f create mode 100644 pkg/tbtables/fitsio/ftgcnn.f create mode 100644 pkg/tbtables/fitsio/ftgcno.f create mode 100644 pkg/tbtables/fitsio/ftgcrd.f create mode 100644 pkg/tbtables/fitsio/ftgcvb.f create mode 100644 pkg/tbtables/fitsio/ftgcvc.f create mode 100644 pkg/tbtables/fitsio/ftgcvd.f create mode 100644 pkg/tbtables/fitsio/ftgcve.f create mode 100644 pkg/tbtables/fitsio/ftgcvi.f create mode 100644 pkg/tbtables/fitsio/ftgcvj.f create mode 100644 pkg/tbtables/fitsio/ftgcvm.f create mode 100644 pkg/tbtables/fitsio/ftgcvs.f create mode 100644 pkg/tbtables/fitsio/ftgcx.f create mode 100644 pkg/tbtables/fitsio/ftgcxd.f create mode 100644 pkg/tbtables/fitsio/ftgcxi.f create mode 100644 pkg/tbtables/fitsio/ftgcxj.f create mode 100644 pkg/tbtables/fitsio/ftgdes.f create mode 100644 pkg/tbtables/fitsio/ftgerr.f create mode 100644 pkg/tbtables/fitsio/ftgext.f create mode 100644 pkg/tbtables/fitsio/ftggpb.f create mode 100644 pkg/tbtables/fitsio/ftggpd.f create mode 100644 pkg/tbtables/fitsio/ftggpe.f create mode 100644 pkg/tbtables/fitsio/ftggpi.f create mode 100644 pkg/tbtables/fitsio/ftggpj.f create mode 100644 pkg/tbtables/fitsio/ftghad.f create mode 100644 pkg/tbtables/fitsio/ftghbn.f create mode 100644 pkg/tbtables/fitsio/ftghdn.f create mode 100644 pkg/tbtables/fitsio/ftghpr.f create mode 100644 pkg/tbtables/fitsio/ftghps.f create mode 100644 pkg/tbtables/fitsio/ftghsp.f create mode 100644 pkg/tbtables/fitsio/ftghtb.f create mode 100644 pkg/tbtables/fitsio/ftgi1b.f create mode 100644 pkg/tbtables/fitsio/ftgics.f create mode 100644 pkg/tbtables/fitsio/ftgiou.f create mode 100644 pkg/tbtables/fitsio/ftgkey.f create mode 100644 pkg/tbtables/fitsio/ftgknd.f create mode 100644 pkg/tbtables/fitsio/ftgkne.f create mode 100644 pkg/tbtables/fitsio/ftgknj.f create mode 100644 pkg/tbtables/fitsio/ftgknl.f create mode 100644 pkg/tbtables/fitsio/ftgkns.f create mode 100644 pkg/tbtables/fitsio/ftgkyd.f create mode 100644 pkg/tbtables/fitsio/ftgkye.f create mode 100644 pkg/tbtables/fitsio/ftgkyj.f create mode 100644 pkg/tbtables/fitsio/ftgkyl.f create mode 100644 pkg/tbtables/fitsio/ftgkyn.f create mode 100644 pkg/tbtables/fitsio/ftgkys.f create mode 100644 pkg/tbtables/fitsio/ftgkyt.f create mode 100644 pkg/tbtables/fitsio/ftgmsg.f create mode 100644 pkg/tbtables/fitsio/ftgnst.f create mode 100644 pkg/tbtables/fitsio/ftgpfb.f create mode 100644 pkg/tbtables/fitsio/ftgpfd.f create mode 100644 pkg/tbtables/fitsio/ftgpfe.f create mode 100644 pkg/tbtables/fitsio/ftgpfi.f create mode 100644 pkg/tbtables/fitsio/ftgpfj.f create mode 100644 pkg/tbtables/fitsio/ftgphx.f create mode 100644 pkg/tbtables/fitsio/ftgprh.f create mode 100644 pkg/tbtables/fitsio/ftgpvb.f create mode 100644 pkg/tbtables/fitsio/ftgpvd.f create mode 100644 pkg/tbtables/fitsio/ftgpve.f create mode 100644 pkg/tbtables/fitsio/ftgpvi.f create mode 100644 pkg/tbtables/fitsio/ftgpvj.f create mode 100644 pkg/tbtables/fitsio/ftgrec.f create mode 100644 pkg/tbtables/fitsio/ftgsfb.f create mode 100644 pkg/tbtables/fitsio/ftgsfd.f create mode 100644 pkg/tbtables/fitsio/ftgsfe.f create mode 100644 pkg/tbtables/fitsio/ftgsfi.f create mode 100644 pkg/tbtables/fitsio/ftgsfj.f create mode 100644 pkg/tbtables/fitsio/ftgsvb.f create mode 100644 pkg/tbtables/fitsio/ftgsvd.f create mode 100644 pkg/tbtables/fitsio/ftgsve.f create mode 100644 pkg/tbtables/fitsio/ftgsvi.f create mode 100644 pkg/tbtables/fitsio/ftgsvj.f create mode 100644 pkg/tbtables/fitsio/ftgtbb.f create mode 100644 pkg/tbtables/fitsio/ftgtbc.f create mode 100644 pkg/tbtables/fitsio/ftgtbh.f create mode 100644 pkg/tbtables/fitsio/ftgtbn.f create mode 100644 pkg/tbtables/fitsio/ftgtbs.f create mode 100644 pkg/tbtables/fitsio/ftgtcl.f create mode 100644 pkg/tbtables/fitsio/ftgtcs.f create mode 100644 pkg/tbtables/fitsio/ftgtdm.f create mode 100644 pkg/tbtables/fitsio/ftgthd.f create mode 100644 pkg/tbtables/fitsio/ftgtkn.f create mode 100644 pkg/tbtables/fitsio/ftgttb.f create mode 100644 pkg/tbtables/fitsio/fthdef.f create mode 100644 pkg/tbtables/fitsio/fthpdn.f create mode 100644 pkg/tbtables/fitsio/fthpup.f create mode 100644 pkg/tbtables/fitsio/fti1i1.f create mode 100644 pkg/tbtables/fitsio/fti1i2.f create mode 100644 pkg/tbtables/fitsio/fti1i4.f create mode 100644 pkg/tbtables/fitsio/fti1r4.f create mode 100644 pkg/tbtables/fitsio/fti1r8.f create mode 100644 pkg/tbtables/fitsio/fti2c.f create mode 100644 pkg/tbtables/fitsio/fti2i1.f create mode 100644 pkg/tbtables/fitsio/fti2i2.f create mode 100644 pkg/tbtables/fitsio/fti2i4.f create mode 100644 pkg/tbtables/fitsio/fti2r4.f create mode 100644 pkg/tbtables/fitsio/fti2r8.f create mode 100644 pkg/tbtables/fitsio/fti4i1.f create mode 100644 pkg/tbtables/fitsio/fti4i2.f create mode 100644 pkg/tbtables/fitsio/fti4i4.f create mode 100644 pkg/tbtables/fitsio/fti4r4.f create mode 100644 pkg/tbtables/fitsio/fti4r8.f create mode 100644 pkg/tbtables/fitsio/ftibin.f create mode 100644 pkg/tbtables/fitsio/ftiblk.f create mode 100644 pkg/tbtables/fitsio/fticol.f create mode 100644 pkg/tbtables/fitsio/ftiimg.f create mode 100644 pkg/tbtables/fitsio/ftikyd.f create mode 100644 pkg/tbtables/fitsio/ftikye.f create mode 100644 pkg/tbtables/fitsio/ftikyf.f create mode 100644 pkg/tbtables/fitsio/ftikyg.f create mode 100644 pkg/tbtables/fitsio/ftikyj.f create mode 100644 pkg/tbtables/fitsio/ftikyl.f create mode 100644 pkg/tbtables/fitsio/ftikys.f create mode 100644 pkg/tbtables/fitsio/ftinit.f create mode 100644 pkg/tbtables/fitsio/ftirec.f create mode 100644 pkg/tbtables/fitsio/ftirow.f create mode 100644 pkg/tbtables/fitsio/ftitab.f create mode 100644 pkg/tbtables/fitsio/ftkeyn.f create mode 100644 pkg/tbtables/fitsio/ftkshf.f create mode 100644 pkg/tbtables/fitsio/ftl2c.f create mode 100644 pkg/tbtables/fitsio/ftmahd.f create mode 100644 pkg/tbtables/fitsio/ftmcom.f create mode 100644 pkg/tbtables/fitsio/ftmcrd.f create mode 100644 pkg/tbtables/fitsio/ftmkey.f create mode 100644 pkg/tbtables/fitsio/ftmkyd.f create mode 100644 pkg/tbtables/fitsio/ftmkye.f create mode 100644 pkg/tbtables/fitsio/ftmkyf.f create mode 100644 pkg/tbtables/fitsio/ftmkyg.f create mode 100644 pkg/tbtables/fitsio/ftmkyj.f create mode 100644 pkg/tbtables/fitsio/ftmkyl.f create mode 100644 pkg/tbtables/fitsio/ftmkys.f create mode 100644 pkg/tbtables/fitsio/ftmnam.f create mode 100644 pkg/tbtables/fitsio/ftmodr.f create mode 100644 pkg/tbtables/fitsio/ftmrec.f create mode 100644 pkg/tbtables/fitsio/ftmrhd.f create mode 100644 pkg/tbtables/fitsio/ftnkey.f create mode 100644 pkg/tbtables/fitsio/ftnulc.f create mode 100644 pkg/tbtables/fitsio/ftnulm.f create mode 100644 pkg/tbtables/fitsio/ftopen.f create mode 100644 pkg/tbtables/fitsio/ftp2db.f create mode 100644 pkg/tbtables/fitsio/ftp2dd.f create mode 100644 pkg/tbtables/fitsio/ftp2de.f create mode 100644 pkg/tbtables/fitsio/ftp2di.f create mode 100644 pkg/tbtables/fitsio/ftp2dj.f create mode 100644 pkg/tbtables/fitsio/ftp3db.f create mode 100644 pkg/tbtables/fitsio/ftp3dd.f create mode 100644 pkg/tbtables/fitsio/ftp3de.f create mode 100644 pkg/tbtables/fitsio/ftp3di.f create mode 100644 pkg/tbtables/fitsio/ftp3dj.f create mode 100644 pkg/tbtables/fitsio/ftpbit.f create mode 100644 pkg/tbtables/fitsio/ftpbnh.f create mode 100644 pkg/tbtables/fitsio/ftpcks.f create mode 100644 pkg/tbtables/fitsio/ftpclb.f create mode 100644 pkg/tbtables/fitsio/ftpclc.f create mode 100644 pkg/tbtables/fitsio/ftpcld.f create mode 100644 pkg/tbtables/fitsio/ftpcle.f create mode 100644 pkg/tbtables/fitsio/ftpcli.f create mode 100644 pkg/tbtables/fitsio/ftpclj.f create mode 100644 pkg/tbtables/fitsio/ftpcll.f create mode 100644 pkg/tbtables/fitsio/ftpclm.f create mode 100644 pkg/tbtables/fitsio/ftpcls.f create mode 100644 pkg/tbtables/fitsio/ftpclu.f create mode 100644 pkg/tbtables/fitsio/ftpclx.f create mode 100644 pkg/tbtables/fitsio/ftpcnb.f create mode 100644 pkg/tbtables/fitsio/ftpcnd.f create mode 100644 pkg/tbtables/fitsio/ftpcne.f create mode 100644 pkg/tbtables/fitsio/ftpcni.f create mode 100644 pkg/tbtables/fitsio/ftpcnj.f create mode 100644 pkg/tbtables/fitsio/ftpcom.f create mode 100644 pkg/tbtables/fitsio/ftpdat.f create mode 100644 pkg/tbtables/fitsio/ftpdef.f create mode 100644 pkg/tbtables/fitsio/ftpdes.f create mode 100644 pkg/tbtables/fitsio/ftpdfl.f create mode 100644 pkg/tbtables/fitsio/ftpgpb.f create mode 100644 pkg/tbtables/fitsio/ftpgpd.f create mode 100644 pkg/tbtables/fitsio/ftpgpe.f create mode 100644 pkg/tbtables/fitsio/ftpgpi.f create mode 100644 pkg/tbtables/fitsio/ftpgpj.f create mode 100644 pkg/tbtables/fitsio/ftphbn.f create mode 100644 pkg/tbtables/fitsio/ftphis.f create mode 100644 pkg/tbtables/fitsio/ftphpr.f create mode 100644 pkg/tbtables/fitsio/ftphtb.f create mode 100644 pkg/tbtables/fitsio/ftpi1b.f create mode 100644 pkg/tbtables/fitsio/ftpini.f create mode 100644 pkg/tbtables/fitsio/ftpkey.f create mode 100644 pkg/tbtables/fitsio/ftpkls.f create mode 100644 pkg/tbtables/fitsio/ftpknd.f create mode 100644 pkg/tbtables/fitsio/ftpkne.f create mode 100644 pkg/tbtables/fitsio/ftpknf.f create mode 100644 pkg/tbtables/fitsio/ftpkng.f create mode 100644 pkg/tbtables/fitsio/ftpknj.f create mode 100644 pkg/tbtables/fitsio/ftpknl.f create mode 100644 pkg/tbtables/fitsio/ftpkns.f create mode 100644 pkg/tbtables/fitsio/ftpkyd.f create mode 100644 pkg/tbtables/fitsio/ftpkye.f create mode 100644 pkg/tbtables/fitsio/ftpkyf.f create mode 100644 pkg/tbtables/fitsio/ftpkyg.f create mode 100644 pkg/tbtables/fitsio/ftpkyj.f create mode 100644 pkg/tbtables/fitsio/ftpkyl.f create mode 100644 pkg/tbtables/fitsio/ftpkys.f create mode 100644 pkg/tbtables/fitsio/ftpkyt.f create mode 100644 pkg/tbtables/fitsio/ftplsw.f create mode 100644 pkg/tbtables/fitsio/ftpmsg.f create mode 100644 pkg/tbtables/fitsio/ftpnul.f create mode 100644 pkg/tbtables/fitsio/ftppnb.f create mode 100644 pkg/tbtables/fitsio/ftppnd.f create mode 100644 pkg/tbtables/fitsio/ftppne.f create mode 100644 pkg/tbtables/fitsio/ftppni.f create mode 100644 pkg/tbtables/fitsio/ftppnj.f create mode 100644 pkg/tbtables/fitsio/ftpprb.f create mode 100644 pkg/tbtables/fitsio/ftpprd.f create mode 100644 pkg/tbtables/fitsio/ftppre.f create mode 100644 pkg/tbtables/fitsio/ftpprh.f create mode 100644 pkg/tbtables/fitsio/ftppri.f create mode 100644 pkg/tbtables/fitsio/ftpprj.f create mode 100644 pkg/tbtables/fitsio/ftppru.f create mode 100644 pkg/tbtables/fitsio/ftprec.f create mode 100644 pkg/tbtables/fitsio/ftprsv.f create mode 100644 pkg/tbtables/fitsio/ftpscl.f create mode 100644 pkg/tbtables/fitsio/ftpssb.f create mode 100644 pkg/tbtables/fitsio/ftpssd.f create mode 100644 pkg/tbtables/fitsio/ftpsse.f create mode 100644 pkg/tbtables/fitsio/ftpssi.f create mode 100644 pkg/tbtables/fitsio/ftpssj.f create mode 100644 pkg/tbtables/fitsio/ftpsvc.f create mode 100644 pkg/tbtables/fitsio/ftptbb.f create mode 100644 pkg/tbtables/fitsio/ftptbh.f create mode 100644 pkg/tbtables/fitsio/ftptbs.f create mode 100644 pkg/tbtables/fitsio/ftptdm.f create mode 100644 pkg/tbtables/fitsio/ftpthp.f create mode 100644 pkg/tbtables/fitsio/ftr2e.f create mode 100644 pkg/tbtables/fitsio/ftr2f.f create mode 100644 pkg/tbtables/fitsio/ftr4i1.f create mode 100644 pkg/tbtables/fitsio/ftr4i2.f create mode 100644 pkg/tbtables/fitsio/ftr4i4.f create mode 100644 pkg/tbtables/fitsio/ftr4r4.f create mode 100644 pkg/tbtables/fitsio/ftr4r8.f create mode 100644 pkg/tbtables/fitsio/ftr8i1.f create mode 100644 pkg/tbtables/fitsio/ftr8i2.f create mode 100644 pkg/tbtables/fitsio/ftr8i4.f create mode 100644 pkg/tbtables/fitsio/ftr8r4.f create mode 100644 pkg/tbtables/fitsio/ftr8r8.f create mode 100644 pkg/tbtables/fitsio/ftrdef.f create mode 100644 pkg/tbtables/fitsio/ftrhdu.f create mode 100644 pkg/tbtables/fitsio/ftrsnm.f create mode 100644 pkg/tbtables/fitsio/ftrwdn.f create mode 100644 pkg/tbtables/fitsio/ftrwup.f create mode 100644 pkg/tbtables/fitsio/fts2c.f create mode 100644 pkg/tbtables/fitsio/ftsdnn.f create mode 100644 pkg/tbtables/fitsio/ftsnul.f create mode 100644 pkg/tbtables/fitsio/ftsrnn.f create mode 100644 pkg/tbtables/fitsio/fttbit.f create mode 100644 pkg/tbtables/fitsio/fttdnn.f create mode 100644 pkg/tbtables/fitsio/fttkey.f create mode 100644 pkg/tbtables/fitsio/fttkyn.f create mode 100644 pkg/tbtables/fitsio/fttnul.f create mode 100644 pkg/tbtables/fitsio/fttrec.f create mode 100644 pkg/tbtables/fitsio/fttrnn.f create mode 100644 pkg/tbtables/fitsio/fttscl.f create mode 100644 pkg/tbtables/fitsio/ftucks.f create mode 100644 pkg/tbtables/fitsio/ftucrd.f create mode 100644 pkg/tbtables/fitsio/ftukyd.f create mode 100644 pkg/tbtables/fitsio/ftukye.f create mode 100644 pkg/tbtables/fitsio/ftukyf.f create mode 100644 pkg/tbtables/fitsio/ftukyg.f create mode 100644 pkg/tbtables/fitsio/ftukyj.f create mode 100644 pkg/tbtables/fitsio/ftukyl.f create mode 100644 pkg/tbtables/fitsio/ftukys.f create mode 100644 pkg/tbtables/fitsio/ftuscc.f create mode 100644 pkg/tbtables/fitsio/ftuscm.f create mode 100644 pkg/tbtables/fitsio/ftvcks.f create mode 100644 pkg/tbtables/fitsio/ftvers.f create mode 100644 pkg/tbtables/fitsio/ftwend.f create mode 100644 pkg/tbtables/fitsio/ftwldp.f create mode 100644 pkg/tbtables/fitsio/ftxiou.f create mode 100644 pkg/tbtables/fitsio/ftxmsg.f create mode 100644 pkg/tbtables/fitsio/ftxypx.f create mode 100644 pkg/tbtables/fitsio/mkpkg create mode 100644 pkg/tbtables/fitsio/unix/README create mode 100644 pkg/tbtables/fitsio/unix/ftgcbf.x create mode 100644 pkg/tbtables/fitsio/unix/ftpcbf.x create mode 100644 pkg/tbtables/fitsio/unix/mkpkg create mode 100644 pkg/tbtables/fitsio/vms/README create mode 100644 pkg/tbtables/fitsio/vms/ftgcbf.x create mode 100644 pkg/tbtables/fitsio/vms/ftpcbf.x create mode 100644 pkg/tbtables/fitsio/vms/mkpkg create mode 100644 pkg/tbtables/fitsio_spp.h create mode 100644 pkg/tbtables/mkpkg create mode 100644 pkg/tbtables/selector/generic/mkpkg create mode 100644 pkg/tbtables/selector/generic/tcsrdaryb.x create mode 100644 pkg/tbtables/selector/generic/tcsrdaryc.x create mode 100644 pkg/tbtables/selector/generic/tcsrdaryd.x create mode 100644 pkg/tbtables/selector/generic/tcsrdaryi.x create mode 100644 pkg/tbtables/selector/generic/tcsrdaryr.x create mode 100644 pkg/tbtables/selector/generic/tcsrdarys.x create mode 100644 pkg/tbtables/selector/mkpkg create mode 100644 pkg/tbtables/selector/omniread.x create mode 100644 pkg/tbtables/selector/rdselect.x create mode 100644 pkg/tbtables/selector/rst.x create mode 100644 pkg/tbtables/selector/selrows.x create mode 100644 pkg/tbtables/selector/tbcga.x create mode 100644 pkg/tbtables/selector/tbcnel.x create mode 100644 pkg/tbtables/selector/tcs.h create mode 100644 pkg/tbtables/selector/tcsaddcol.x create mode 100644 pkg/tbtables/selector/tcsclose.x create mode 100644 pkg/tbtables/selector/tcscolumn.x create mode 100644 pkg/tbtables/selector/tcsintinfo.x create mode 100644 pkg/tbtables/selector/tcslinesize.x create mode 100644 pkg/tbtables/selector/tcsopen.x create mode 100644 pkg/tbtables/selector/tcsrdary.gx create mode 100644 pkg/tbtables/selector/tcsshape.x create mode 100644 pkg/tbtables/selector/tcstotsize.x create mode 100644 pkg/tbtables/selector/tcstxtinfo.x create mode 100644 pkg/tbtables/selector/trs.h create mode 100644 pkg/tbtables/selector/trsclose.x create mode 100644 pkg/tbtables/selector/trseval.x create mode 100644 pkg/tbtables/selector/trsgencode.x create mode 100644 pkg/tbtables/selector/trsopen.com create mode 100644 pkg/tbtables/selector/trsopen.x create mode 100644 pkg/tbtables/selector/trsopen.y create mode 100644 pkg/tbtables/selector/trsrows.x create mode 100644 pkg/tbtables/selector/trstree.x create mode 100644 pkg/tbtables/selector/trstrim.x create mode 100644 pkg/tbtables/selector/whatfile.h create mode 100644 pkg/tbtables/selector/whatfile.x create mode 100644 pkg/tbtables/tbagt.x create mode 100644 pkg/tbtables/tbapt.x create mode 100644 pkg/tbtables/tbbadf.x create mode 100644 pkg/tbtables/tbbaln.x create mode 100644 pkg/tbtables/tbbcmt.x create mode 100644 pkg/tbtables/tbbftp.x create mode 100644 pkg/tbtables/tbbnll.x create mode 100644 pkg/tbtables/tbbptf.x create mode 100644 pkg/tbtables/tbbtyp.x create mode 100644 pkg/tbtables/tbbwrd.x create mode 100644 pkg/tbtables/tbcadd.x create mode 100644 pkg/tbtables/tbcchg.x create mode 100644 pkg/tbtables/tbcdef.x create mode 100644 pkg/tbtables/tbcdef1.x create mode 100644 pkg/tbtables/tbcdes.x create mode 100644 pkg/tbtables/tbcfmt.x create mode 100644 pkg/tbtables/tbcfnd.x create mode 100644 pkg/tbtables/tbcfnd1.x create mode 100644 pkg/tbtables/tbcftl.x create mode 100644 pkg/tbtables/tbcgt.x create mode 100644 pkg/tbtables/tbciga.x create mode 100644 pkg/tbtables/tbcigi.x create mode 100644 pkg/tbtables/tbcigt.x create mode 100644 pkg/tbtables/tbcinf.x create mode 100644 pkg/tbtables/tbcnam.x create mode 100644 pkg/tbtables/tbcnit.x create mode 100644 pkg/tbtables/tbcnum.x create mode 100644 pkg/tbtables/tbcpt.x create mode 100644 pkg/tbtables/tbcrcd.x create mode 100644 pkg/tbtables/tbcscal.x create mode 100644 pkg/tbtables/tbctpe.x create mode 100644 pkg/tbtables/tbcwcd.x create mode 100644 pkg/tbtables/tbdsav.x create mode 100644 pkg/tbtables/tbegp.x create mode 100644 pkg/tbtables/tbegt.x create mode 100644 pkg/tbtables/tbeoff.x create mode 100644 pkg/tbtables/tbepp.x create mode 100644 pkg/tbtables/tbept.x create mode 100644 pkg/tbtables/tbeszt.x create mode 100644 pkg/tbtables/tbfag.x create mode 100644 pkg/tbtables/tbfanp.x create mode 100644 pkg/tbtables/tbfap.x create mode 100644 pkg/tbtables/tbfcal.x create mode 100644 pkg/tbtables/tbfchp.x create mode 100644 pkg/tbtables/tbfckn.x create mode 100644 pkg/tbtables/tbfclo.x create mode 100644 pkg/tbtables/tbfdef.x create mode 100644 pkg/tbtables/tbfdel.x create mode 100644 pkg/tbtables/tbferr.x create mode 100644 pkg/tbtables/tbffkw.x create mode 100644 pkg/tbtables/tbffmt.x create mode 100644 pkg/tbtables/tbffnd.x create mode 100644 pkg/tbtables/tbfgcm.x create mode 100644 pkg/tbtables/tbfgnp.x create mode 100644 pkg/tbtables/tbfhdl.x create mode 100644 pkg/tbtables/tbfhg.x create mode 100644 pkg/tbtables/tbfhp.x create mode 100644 pkg/tbtables/tbfhp_f.x create mode 100644 pkg/tbtables/tbfiga.x create mode 100644 pkg/tbtables/tbfnam.x create mode 100644 pkg/tbtables/tbfnew.x create mode 100644 pkg/tbtables/tbfnit.x create mode 100644 pkg/tbtables/tbfnll.x create mode 100644 pkg/tbtables/tbfopn.x create mode 100644 pkg/tbtables/tbfpcm.x create mode 100644 pkg/tbtables/tbfpnp.x create mode 100644 pkg/tbtables/tbfpri.x create mode 100644 pkg/tbtables/tbfptf.x create mode 100644 pkg/tbtables/tbfrcd.x create mode 100644 pkg/tbtables/tbfres.x create mode 100644 pkg/tbtables/tbfrsi.x create mode 100644 pkg/tbtables/tbfscal.x create mode 100644 pkg/tbtables/tbfsft.x create mode 100644 pkg/tbtables/tbfsiz.x create mode 100644 pkg/tbtables/tbftya.x create mode 100644 pkg/tbtables/tbftyb.x create mode 100644 pkg/tbtables/tbfudf.x create mode 100644 pkg/tbtables/tbfwcd.x create mode 100644 pkg/tbtables/tbfwer.x create mode 100644 pkg/tbtables/tbfwsi.x create mode 100644 pkg/tbtables/tbfxff.c create mode 100644 pkg/tbtables/tbhad.x create mode 100644 pkg/tbtables/tbhanp.x create mode 100644 pkg/tbtables/tbhcal.x create mode 100644 pkg/tbtables/tbhckn.x create mode 100644 pkg/tbtables/tbhdel.x create mode 100644 pkg/tbtables/tbhfcm.x create mode 100644 pkg/tbtables/tbhfkr.x create mode 100644 pkg/tbtables/tbhfkw.x create mode 100644 pkg/tbtables/tbhgcm.x create mode 100644 pkg/tbtables/tbhgnp.x create mode 100644 pkg/tbtables/tbhgt.x create mode 100644 pkg/tbtables/tbhisc.x create mode 100644 pkg/tbtables/tbhkeq.x create mode 100644 pkg/tbtables/tbhpcm.x create mode 100644 pkg/tbtables/tbhpnp.x create mode 100644 pkg/tbtables/tbhpt.x create mode 100644 pkg/tbtables/tbhrpr.x create mode 100644 pkg/tbtables/tbhwpr.x create mode 100644 pkg/tbtables/tblerr.h create mode 100644 pkg/tbtables/tblfits.h create mode 100644 pkg/tbtables/tbltext.h create mode 100644 pkg/tbtables/tbnopen.x create mode 100644 pkg/tbtables/tbnparse.x create mode 100644 pkg/tbtables/tbparse.x create mode 100644 pkg/tbtables/tbpset.x create mode 100644 pkg/tbtables/tbpsta.x create mode 100644 pkg/tbtables/tbrchg.x create mode 100644 pkg/tbtables/tbrcmp.x create mode 100644 pkg/tbtables/tbrcpy.x create mode 100644 pkg/tbtables/tbrcsc.x create mode 100644 pkg/tbtables/tbrdel.x create mode 100644 pkg/tbtables/tbrgt.x create mode 100644 pkg/tbtables/tbrnll.x create mode 100644 pkg/tbtables/tbrpt.x create mode 100644 pkg/tbtables/tbrsft.x create mode 100644 pkg/tbtables/tbrswp.x create mode 100644 pkg/tbtables/tbrudf.x create mode 100644 pkg/tbtables/tbscol.x create mode 100644 pkg/tbtables/tbsirow.x create mode 100644 pkg/tbtables/tbsopn.x create mode 100644 pkg/tbtables/tbsrow.x create mode 100644 pkg/tbtables/tbswer.x create mode 100644 pkg/tbtables/tbswer1.x create mode 100644 pkg/tbtables/tbtables.h create mode 100644 pkg/tbtables/tbtacc.x create mode 100644 pkg/tbtables/tbtbod.x create mode 100644 pkg/tbtables/tbtchs.x create mode 100644 pkg/tbtables/tbtclo.x create mode 100644 pkg/tbtables/tbtcpy.x create mode 100644 pkg/tbtables/tbtcre.x create mode 100644 pkg/tbtables/tbtdel.x create mode 100644 pkg/tbtables/tbtext.x create mode 100644 pkg/tbtables/tbtflu.x create mode 100644 pkg/tbtables/tbtfst.x create mode 100644 pkg/tbtables/tbtnam.x create mode 100644 pkg/tbtables/tbtopn.x create mode 100644 pkg/tbtables/tbtopns.x create mode 100644 pkg/tbtables/tbtren.x create mode 100644 pkg/tbtables/tbtrsi.x create mode 100644 pkg/tbtables/tbtscd.x create mode 100644 pkg/tbtables/tbtscu.x create mode 100644 pkg/tbtables/tbtsrt.x create mode 100644 pkg/tbtables/tbttyp.x create mode 100644 pkg/tbtables/tbtwer.x create mode 100644 pkg/tbtables/tbtwsi.x create mode 100644 pkg/tbtables/tbuopn.x create mode 100644 pkg/tbtables/tbxag.x create mode 100644 pkg/tbtables/tbxap.x create mode 100644 pkg/tbtables/tbxcg.x create mode 100644 pkg/tbtables/tbxcp.x create mode 100644 pkg/tbtables/tbxncn.x create mode 100644 pkg/tbtables/tbxnew.x create mode 100644 pkg/tbtables/tbxnll.x create mode 100644 pkg/tbtables/tbxoff.x create mode 100644 pkg/tbtables/tbxrg.x create mode 100644 pkg/tbtables/tbxrp.x create mode 100644 pkg/tbtables/tbxscp.x create mode 100644 pkg/tbtables/tbxsft.x create mode 100644 pkg/tbtables/tbxsiz.x create mode 100644 pkg/tbtables/tbxudf.x create mode 100644 pkg/tbtables/tbxwer.x create mode 100644 pkg/tbtables/tbxwnc.x create mode 100644 pkg/tbtables/tbycg.x create mode 100644 pkg/tbtables/tbycp.x create mode 100644 pkg/tbtables/tbyncn.x create mode 100644 pkg/tbtables/tbynew.x create mode 100644 pkg/tbtables/tbynll.x create mode 100644 pkg/tbtables/tbyoff.x create mode 100644 pkg/tbtables/tbyrg.x create mode 100644 pkg/tbtables/tbyrp.x create mode 100644 pkg/tbtables/tbyscn.x create mode 100644 pkg/tbtables/tbyscp.x create mode 100644 pkg/tbtables/tbysft.x create mode 100644 pkg/tbtables/tbysiz.x create mode 100644 pkg/tbtables/tbyudf.x create mode 100644 pkg/tbtables/tbywer.x create mode 100644 pkg/tbtables/tbywnc.x create mode 100644 pkg/tbtables/tbzadd.x create mode 100644 pkg/tbtables/tbzcg.x create mode 100644 pkg/tbtables/tbzclo.x create mode 100644 pkg/tbtables/tbzcol.x create mode 100644 pkg/tbtables/tbzcp.x create mode 100644 pkg/tbtables/tbzd2t.x create mode 100644 pkg/tbtables/tbzgt.x create mode 100644 pkg/tbtables/tbzi2d.x create mode 100644 pkg/tbtables/tbzi2t.x create mode 100644 pkg/tbtables/tbzkey.x create mode 100644 pkg/tbtables/tbzlin.x create mode 100644 pkg/tbtables/tbzmem.x create mode 100644 pkg/tbtables/tbznew.x create mode 100644 pkg/tbtables/tbznll.x create mode 100644 pkg/tbtables/tbzopn.x create mode 100644 pkg/tbtables/tbzpt.x create mode 100644 pkg/tbtables/tbzrds.x create mode 100644 pkg/tbtables/tbzrdx.x create mode 100644 pkg/tbtables/tbzsft.x create mode 100644 pkg/tbtables/tbzsiz.x create mode 100644 pkg/tbtables/tbzsub.x create mode 100644 pkg/tbtables/tbzt2t.x create mode 100644 pkg/tbtables/tbztyp.x create mode 100644 pkg/tbtables/tbzudf.x create mode 100644 pkg/tbtables/tbzwer.x create mode 100644 pkg/tbtables/tbzwrt.x create mode 100644 pkg/tbtables/underscore.h create mode 100644 pkg/utilities/README create mode 100644 pkg/utilities/Revisions create mode 100644 pkg/utilities/bases.cl create mode 100644 pkg/utilities/curfit.gx create mode 100644 pkg/utilities/curfit.h create mode 100644 pkg/utilities/curfit.par create mode 100644 pkg/utilities/curfit.x create mode 100644 pkg/utilities/decod_tablst.x create mode 100644 pkg/utilities/detab.par create mode 100644 pkg/utilities/doc/bases.hlp create mode 100644 pkg/utilities/doc/curfit.hlp create mode 100644 pkg/utilities/doc/detab.hlp create mode 100644 pkg/utilities/doc/entab.hlp create mode 100644 pkg/utilities/doc/lcase.hlp create mode 100644 pkg/utilities/doc/polyfit.hlp create mode 100644 pkg/utilities/doc/split.hlp create mode 100644 pkg/utilities/doc/surfit.hlp create mode 100644 pkg/utilities/doc/translit.hlp create mode 100644 pkg/utilities/doc/ucase.hlp create mode 100644 pkg/utilities/doc/urand.hlp create mode 100644 pkg/utilities/entab.par create mode 100644 pkg/utilities/lcase.par create mode 100644 pkg/utilities/mkpkg create mode 100644 pkg/utilities/nttools/README create mode 100644 pkg/utilities/nttools/atools/mkpkg create mode 100644 pkg/utilities/nttools/atools/taextract.x create mode 100644 pkg/utilities/nttools/atools/taincr.x create mode 100644 pkg/utilities/nttools/atools/tainsert.x create mode 100644 pkg/utilities/nttools/copyone/addslash.x create mode 100644 pkg/utilities/nttools/copyone/datatype.x create mode 100644 pkg/utilities/nttools/copyone/filetype.h create mode 100644 pkg/utilities/nttools/copyone/filetype.x create mode 100644 pkg/utilities/nttools/copyone/filetype.x.OLD create mode 100644 pkg/utilities/nttools/copyone/getimghdr.x create mode 100644 pkg/utilities/nttools/copyone/gettabdat.x create mode 100644 pkg/utilities/nttools/copyone/gettabhdr.x create mode 100644 pkg/utilities/nttools/copyone/isdouble.x create mode 100644 pkg/utilities/nttools/copyone/keypar.x create mode 100644 pkg/utilities/nttools/copyone/keytab.x create mode 100644 pkg/utilities/nttools/copyone/mkpkg create mode 100644 pkg/utilities/nttools/copyone/parkey.x create mode 100644 pkg/utilities/nttools/copyone/partab.x create mode 100644 pkg/utilities/nttools/copyone/putimghdr.x create mode 100644 pkg/utilities/nttools/copyone/puttabdat.x create mode 100644 pkg/utilities/nttools/copyone/puttabhdr.x create mode 100644 pkg/utilities/nttools/copyone/tabaccess.x create mode 100644 pkg/utilities/nttools/copyone/tabhdrtyp.x create mode 100644 pkg/utilities/nttools/copyone/tabkey.x create mode 100644 pkg/utilities/nttools/copyone/tabpar.x create mode 100644 pkg/utilities/nttools/doc/axispar.hlp create mode 100644 pkg/utilities/nttools/doc/dvpar.hlp create mode 100644 pkg/utilities/nttools/doc/gtedit.hlp create mode 100644 pkg/utilities/nttools/doc/gtpar.hlp create mode 100644 pkg/utilities/nttools/doc/imtab.hlp create mode 100644 pkg/utilities/nttools/doc/keypar.hlp create mode 100644 pkg/utilities/nttools/doc/keyselect.hlp create mode 100644 pkg/utilities/nttools/doc/keytab.hlp create mode 100644 pkg/utilities/nttools/doc/parkey.hlp create mode 100644 pkg/utilities/nttools/doc/partab.hlp create mode 100644 pkg/utilities/nttools/doc/pltpar.hlp create mode 100644 pkg/utilities/nttools/doc/tabim.hlp create mode 100644 pkg/utilities/nttools/doc/tabkey.hlp create mode 100644 pkg/utilities/nttools/doc/tabpar.hlp create mode 100644 pkg/utilities/nttools/doc/taextract.hlp create mode 100644 pkg/utilities/nttools/doc/tainsert.hlp create mode 100644 pkg/utilities/nttools/doc/tcalc.hlp create mode 100644 pkg/utilities/nttools/doc/tchcol.hlp create mode 100644 pkg/utilities/nttools/doc/tcheck.hlp create mode 100644 pkg/utilities/nttools/doc/tchsize.hlp create mode 100644 pkg/utilities/nttools/doc/tcopy.hlp create mode 100644 pkg/utilities/nttools/doc/tcreate.hlp create mode 100644 pkg/utilities/nttools/doc/tdelete.hlp create mode 100644 pkg/utilities/nttools/doc/tdiffer.hlp create mode 100644 pkg/utilities/nttools/doc/tdump.hlp create mode 100644 pkg/utilities/nttools/doc/tedit.hlp create mode 100644 pkg/utilities/nttools/doc/texpand.hlp create mode 100644 pkg/utilities/nttools/doc/thedit.hlp create mode 100644 pkg/utilities/nttools/doc/thistogram.hlp create mode 100644 pkg/utilities/nttools/doc/thselect.hlp create mode 100644 pkg/utilities/nttools/doc/tinfo.hlp create mode 100644 pkg/utilities/nttools/doc/tintegrate.hlp create mode 100644 pkg/utilities/nttools/doc/tjoin.hlp create mode 100644 pkg/utilities/nttools/doc/tlcol.hlp create mode 100644 pkg/utilities/nttools/doc/tlinear.hlp create mode 100644 pkg/utilities/nttools/doc/tmatch.hlp create mode 100644 pkg/utilities/nttools/doc/tmerge.hlp create mode 100644 pkg/utilities/nttools/doc/tprint.hlp create mode 100644 pkg/utilities/nttools/doc/tproduct.hlp create mode 100644 pkg/utilities/nttools/doc/tproject.hlp create mode 100644 pkg/utilities/nttools/doc/tquery.hlp create mode 100644 pkg/utilities/nttools/doc/tread.hlp create mode 100644 pkg/utilities/nttools/doc/trebin.hlp create mode 100644 pkg/utilities/nttools/doc/tselect.hlp create mode 100644 pkg/utilities/nttools/doc/tsort.hlp create mode 100644 pkg/utilities/nttools/doc/tstat.hlp create mode 100644 pkg/utilities/nttools/doc/ttranspose.hlp create mode 100644 pkg/utilities/nttools/doc/tunits.hlp create mode 100644 pkg/utilities/nttools/doc/tupar.hlp create mode 100644 pkg/utilities/nttools/doc/wcspars.hlp create mode 100644 pkg/utilities/nttools/doc/wlpars.hlp create mode 100644 pkg/utilities/nttools/gtedit.par create mode 100644 pkg/utilities/nttools/gtedit/gtdelete.x create mode 100644 pkg/utilities/nttools/gtedit/gtdodel.x create mode 100644 pkg/utilities/nttools/gtedit/gtedit.key create mode 100644 pkg/utilities/nttools/gtedit/gthinfo.x create mode 100644 pkg/utilities/nttools/gtedit/gtplot.x create mode 100644 pkg/utilities/nttools/gtedit/gtrdxycol.x create mode 100644 pkg/utilities/nttools/gtedit/gtupdate.x create mode 100644 pkg/utilities/nttools/gtedit/gtwrdata.x create mode 100644 pkg/utilities/nttools/gtedit/gtwrhead.x create mode 100644 pkg/utilities/nttools/gtedit/mkpkg create mode 100644 pkg/utilities/nttools/gtedit/t_gtedit.x create mode 100644 pkg/utilities/nttools/gtpar.par create mode 100644 pkg/utilities/nttools/imtab.par create mode 100644 pkg/utilities/nttools/imtab/imtab.h create mode 100644 pkg/utilities/nttools/imtab/imtab.x create mode 100644 pkg/utilities/nttools/imtab/itbwcs.x create mode 100644 pkg/utilities/nttools/imtab/mkpkg create mode 100644 pkg/utilities/nttools/imtab/tabim.x create mode 100644 pkg/utilities/nttools/keypar.par create mode 100644 pkg/utilities/nttools/keyselect.par create mode 100644 pkg/utilities/nttools/keyselect/expr.x create mode 100644 pkg/utilities/nttools/keyselect/keyselect.com create mode 100644 pkg/utilities/nttools/keyselect/keyselect.h create mode 100644 pkg/utilities/nttools/keyselect/keyselect.x create mode 100644 pkg/utilities/nttools/keyselect/keyword.x create mode 100644 pkg/utilities/nttools/keyselect/list.x create mode 100644 pkg/utilities/nttools/keyselect/mkpkg create mode 100644 pkg/utilities/nttools/keyselect/tab.x create mode 100644 pkg/utilities/nttools/keytab.par create mode 100644 pkg/utilities/nttools/lib/allcols.x create mode 100644 pkg/utilities/nttools/lib/allrows.x create mode 100644 pkg/utilities/nttools/lib/compare.com create mode 100644 pkg/utilities/nttools/lib/compare.x create mode 100644 pkg/utilities/nttools/lib/ftnexpr.x create mode 100644 pkg/utilities/nttools/lib/gettabcol.x create mode 100644 pkg/utilities/nttools/lib/inquotes.x create mode 100644 pkg/utilities/nttools/lib/invert.x create mode 100644 pkg/utilities/nttools/lib/mjd.x create mode 100644 pkg/utilities/nttools/lib/mkpkg create mode 100644 pkg/utilities/nttools/lib/movenulls.x create mode 100644 pkg/utilities/nttools/lib/msort.x create mode 100644 pkg/utilities/nttools/lib/newcolnam.x create mode 100644 pkg/utilities/nttools/lib/reloperr.h create mode 100644 pkg/utilities/nttools/lib/reorder.x create mode 100644 pkg/utilities/nttools/lib/select.x create mode 100644 pkg/utilities/nttools/lib/tabvar.x create mode 100644 pkg/utilities/nttools/lib/tbfile.x create mode 100644 pkg/utilities/nttools/lib/tbleval.x create mode 100644 pkg/utilities/nttools/lib/tbljoin.x create mode 100644 pkg/utilities/nttools/lib/tblmerge.x create mode 100644 pkg/utilities/nttools/lib/tblsearch.x create mode 100644 pkg/utilities/nttools/lib/tblsort.x create mode 100644 pkg/utilities/nttools/lib/tblsort1.x create mode 100644 pkg/utilities/nttools/lib/tblsortm.x create mode 100644 pkg/utilities/nttools/lib/tblterm.com create mode 100644 pkg/utilities/nttools/lib/tblterm.x create mode 100644 pkg/utilities/nttools/lib/tctexp.x create mode 100644 pkg/utilities/nttools/lib/tldtype.x create mode 100644 pkg/utilities/nttools/lib/tuopen.x create mode 100644 pkg/utilities/nttools/lib/unique.x create mode 100644 pkg/utilities/nttools/mkpkg create mode 100644 pkg/utilities/nttools/nttools.cl create mode 100644 pkg/utilities/nttools/nttools.hd create mode 100644 pkg/utilities/nttools/nttools.hlp create mode 100644 pkg/utilities/nttools/nttools.men create mode 100644 pkg/utilities/nttools/nttools.par create mode 100644 pkg/utilities/nttools/parkey.par create mode 100644 pkg/utilities/nttools/partab.par create mode 100644 pkg/utilities/nttools/stxtools/changt.x create mode 100644 pkg/utilities/nttools/stxtools/checkdim.x create mode 100644 pkg/utilities/nttools/stxtools/cif.h create mode 100644 pkg/utilities/nttools/stxtools/cif.x create mode 100644 pkg/utilities/nttools/stxtools/clgnone.x create mode 100644 pkg/utilities/nttools/stxtools/copyimg.x create mode 100644 pkg/utilities/nttools/stxtools/doc/wcs.doc create mode 100644 pkg/utilities/nttools/stxtools/errxit.x create mode 100644 pkg/utilities/nttools/stxtools/fbuild.x create mode 100644 pkg/utilities/nttools/stxtools/fparse.x create mode 100644 pkg/utilities/nttools/stxtools/grmimy.x create mode 100644 pkg/utilities/nttools/stxtools/isblank.x create mode 100644 pkg/utilities/nttools/stxtools/lubksb.f create mode 100644 pkg/utilities/nttools/stxtools/lubksd.f create mode 100644 pkg/utilities/nttools/stxtools/ludcmd.x create mode 100644 pkg/utilities/nttools/stxtools/ludcmp.x create mode 100644 pkg/utilities/nttools/stxtools/mkpkg create mode 100644 pkg/utilities/nttools/stxtools/od/mkpkg create mode 100644 pkg/utilities/nttools/stxtools/od/od.h create mode 100644 pkg/utilities/nttools/stxtools/od/odget.x create mode 100644 pkg/utilities/nttools/stxtools/od/odmap.x create mode 100644 pkg/utilities/nttools/stxtools/od/odopep.x create mode 100644 pkg/utilities/nttools/stxtools/od/odpare.x create mode 100644 pkg/utilities/nttools/stxtools/od/odput.x create mode 100644 pkg/utilities/nttools/stxtools/od/odsetn.x create mode 100644 pkg/utilities/nttools/stxtools/od/odunmp.x create mode 100644 pkg/utilities/nttools/stxtools/od/odwcsn.x create mode 100644 pkg/utilities/nttools/stxtools/postexit.x create mode 100644 pkg/utilities/nttools/stxtools/savgol.x create mode 100644 pkg/utilities/nttools/stxtools/sbuf.h create mode 100644 pkg/utilities/nttools/stxtools/sbuf.x create mode 100644 pkg/utilities/nttools/stxtools/sgcone.x create mode 100644 pkg/utilities/nttools/stxtools/similar.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/mkpkg create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spchag.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spdise.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spmapt.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/sprote.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spstry.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/sptras.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spw2ld.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spwcss.x create mode 100644 pkg/utilities/nttools/stxtools/strjust.x create mode 100644 pkg/utilities/nttools/stxtools/stxgetcoord.x create mode 100644 pkg/utilities/nttools/stxtools/template.h create mode 100644 pkg/utilities/nttools/stxtools/tpbreak.x create mode 100644 pkg/utilities/nttools/stxtools/tpclose.x create mode 100644 pkg/utilities/nttools/stxtools/tpcount.x create mode 100644 pkg/utilities/nttools/stxtools/tpfetch.x create mode 100644 pkg/utilities/nttools/stxtools/tpgroup.x create mode 100644 pkg/utilities/nttools/stxtools/tpimtype.x create mode 100644 pkg/utilities/nttools/stxtools/tpopen.x create mode 100644 pkg/utilities/nttools/stxtools/tpparse.x create mode 100644 pkg/utilities/nttools/stxtools/vex.com create mode 100644 pkg/utilities/nttools/stxtools/vex.h create mode 100644 pkg/utilities/nttools/stxtools/vexcompile.x create mode 100644 pkg/utilities/nttools/stxtools/vexcompile.y create mode 100644 pkg/utilities/nttools/stxtools/vexeval.x create mode 100644 pkg/utilities/nttools/stxtools/vexfree.x create mode 100644 pkg/utilities/nttools/stxtools/vexfunc.x create mode 100644 pkg/utilities/nttools/stxtools/vexstack.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/mkpkg create mode 100644 pkg/utilities/nttools/stxtools/wcslab/mkpkg.ori create mode 100644 pkg/utilities/nttools/stxtools/wcslab/psiescape.h create mode 100644 pkg/utilities/nttools/stxtools/wcslab/t_wcslab.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wcs_desc.h create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wcslab.h create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wcslab.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wlgrid.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wllabel.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wllabel.x.ori create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wlsetup.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wlutil.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wlwcslab.x create mode 100644 pkg/utilities/nttools/stxtools/word.x create mode 100644 pkg/utilities/nttools/stxtools/xtwcs.x create mode 100644 pkg/utilities/nttools/tabim.par create mode 100644 pkg/utilities/nttools/tabkey.par create mode 100644 pkg/utilities/nttools/tabpar.par create mode 100644 pkg/utilities/nttools/tabvar.com create mode 100644 pkg/utilities/nttools/taextract.par create mode 100644 pkg/utilities/nttools/tainsert.par create mode 100644 pkg/utilities/nttools/tcalc.par create mode 100644 pkg/utilities/nttools/tcalc/mkpkg create mode 100644 pkg/utilities/nttools/tcalc/tcalc.x create mode 100644 pkg/utilities/nttools/tchcol.par create mode 100644 pkg/utilities/nttools/tchcol/mkpkg create mode 100644 pkg/utilities/nttools/tchcol/tchcol.x create mode 100644 pkg/utilities/nttools/tcheck.par create mode 100644 pkg/utilities/nttools/tcheck/cmdsplit.x create mode 100644 pkg/utilities/nttools/tcheck/mkpkg create mode 100644 pkg/utilities/nttools/tcheck/tcheck.h create mode 100644 pkg/utilities/nttools/tcheck/tcheck.x create mode 100644 pkg/utilities/nttools/tcheck/wrtcheck.x create mode 100644 pkg/utilities/nttools/tchsize.par create mode 100644 pkg/utilities/nttools/tchsize/mkpkg create mode 100644 pkg/utilities/nttools/tchsize/tchsize.x create mode 100644 pkg/utilities/nttools/tcopy.par create mode 100644 pkg/utilities/nttools/tcopy/iswholetab.x create mode 100644 pkg/utilities/nttools/tcopy/mkpkg create mode 100644 pkg/utilities/nttools/tcopy/tcopy.x create mode 100644 pkg/utilities/nttools/tcopy/tdelete.x create mode 100644 pkg/utilities/nttools/tcopy/trename.x create mode 100644 pkg/utilities/nttools/tcreate.par create mode 100644 pkg/utilities/nttools/tcreate/gnextl.x create mode 100644 pkg/utilities/nttools/tcreate/mkpkg create mode 100644 pkg/utilities/nttools/tcreate/tcreate.x create mode 100644 pkg/utilities/nttools/tdelete.par create mode 100644 pkg/utilities/nttools/tdiffer.par create mode 100644 pkg/utilities/nttools/tdiffer/mkpkg create mode 100644 pkg/utilities/nttools/tdiffer/tbldiff.x create mode 100644 pkg/utilities/nttools/tdiffer/tdiffer.x create mode 100644 pkg/utilities/nttools/tdump.par create mode 100644 pkg/utilities/nttools/tedit.par create mode 100644 pkg/utilities/nttools/tedit/bell.x create mode 100644 pkg/utilities/nttools/tedit/command.com create mode 100644 pkg/utilities/nttools/tedit/command.h create mode 100644 pkg/utilities/nttools/tedit/command.x create mode 100644 pkg/utilities/nttools/tedit/display/curses.h create mode 100644 pkg/utilities/nttools/tedit/display/curses/README create mode 100644 pkg/utilities/nttools/tedit/display/curses/addch.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/addstr.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/bindstruct.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/box.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/clear.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/clearok.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/clrtobot.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/clrtoeol.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/delch.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/deleteln.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/delwin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/echo.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/endwin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/erase.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/freescreen.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/getch.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/getscreen.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/getstr.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/getstruct.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/getyx.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/hidewin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/inch.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/initscr.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/insch.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/insertln.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/leaveok.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/mkpkg create mode 100644 pkg/utilities/nttools/tedit/display/curses/move.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/mvwin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/mvword.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/newwin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/omkpkg create mode 100644 pkg/utilities/nttools/tedit/display/curses/putscreen.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/refresh.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/savewin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/scrollok.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/showwin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/standout.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/wdimen.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/window.com create mode 100644 pkg/utilities/nttools/tedit/display/curses/window.h create mode 100644 pkg/utilities/nttools/tedit/display/curses/winstat.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/wslide.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/README create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmbegin.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmcheck.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmend.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmgetform.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmhelp.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmmkform.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmprompt.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmredraw.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/formfn.h create mode 100644 pkg/utilities/nttools/tedit/display/forms/formfn.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/forms.com create mode 100644 pkg/utilities/nttools/tedit/display/forms/linefn.h create mode 100644 pkg/utilities/nttools/tedit/display/forms/linefn.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/mkpkg create mode 100644 pkg/utilities/nttools/tedit/display/forms/promptfn.h create mode 100644 pkg/utilities/nttools/tedit/display/forms/promptfn.x create mode 100644 pkg/utilities/nttools/tedit/display/mkpkg create mode 100644 pkg/utilities/nttools/tedit/display/screen/README create mode 100644 pkg/utilities/nttools/tedit/display/screen/kbegin.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kcompile.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kconvert.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kdoline.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kend.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kget.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/khelp.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kpushbk.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/mkpkg create mode 100644 pkg/utilities/nttools/tedit/display/screen/psbeep.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psbegin.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psend.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psfill.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psheight.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psintersect.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psscreen.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pssendcap.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pssetcur.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psslide.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pssynch.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pswidth.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pswrite.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pswrtcells.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/screen.com create mode 100644 pkg/utilities/nttools/tedit/edit.x create mode 100644 pkg/utilities/nttools/tedit/field.h create mode 100644 pkg/utilities/nttools/tedit/field.x create mode 100644 pkg/utilities/nttools/tedit/mkpkg create mode 100644 pkg/utilities/nttools/tedit/paste.h create mode 100644 pkg/utilities/nttools/tedit/paste.x create mode 100644 pkg/utilities/nttools/tedit/prompt.x create mode 100644 pkg/utilities/nttools/tedit/screen.h create mode 100644 pkg/utilities/nttools/tedit/screen.x create mode 100644 pkg/utilities/nttools/tedit/substitute.x create mode 100644 pkg/utilities/nttools/tedit/table.h create mode 100644 pkg/utilities/nttools/tedit/table.x create mode 100644 pkg/utilities/nttools/tedit/tedit.key create mode 100644 pkg/utilities/nttools/tedit/tedit.x create mode 100644 pkg/utilities/nttools/tedit/tread.x create mode 100644 pkg/utilities/nttools/tedit/window.com create mode 100644 pkg/utilities/nttools/tedit/window.x create mode 100644 pkg/utilities/nttools/texpand.par create mode 100644 pkg/utilities/nttools/texpand/dbgrules.x create mode 100644 pkg/utilities/nttools/texpand/lexer.x create mode 100644 pkg/utilities/nttools/texpand/lexoper.h create mode 100644 pkg/utilities/nttools/texpand/mkpkg create mode 100644 pkg/utilities/nttools/texpand/mkrules.x create mode 100644 pkg/utilities/nttools/texpand/movelem.x create mode 100644 pkg/utilities/nttools/texpand/movtbrow.x create mode 100644 pkg/utilities/nttools/texpand/parser.com create mode 100644 pkg/utilities/nttools/texpand/parser.x create mode 100644 pkg/utilities/nttools/texpand/pushstack.x create mode 100644 pkg/utilities/nttools/texpand/span.x create mode 100644 pkg/utilities/nttools/texpand/texpand.x create mode 100644 pkg/utilities/nttools/texpand/userules.x create mode 100644 pkg/utilities/nttools/texpand/x_texpand.x create mode 100644 pkg/utilities/nttools/thedit.par create mode 100644 pkg/utilities/nttools/thedit/mkpkg create mode 100644 pkg/utilities/nttools/thedit/t_thedit.x create mode 100644 pkg/utilities/nttools/thedit/t_thselect.x create mode 100644 pkg/utilities/nttools/thedit/tkw.x create mode 100644 pkg/utilities/nttools/thistogram.par create mode 100644 pkg/utilities/nttools/threed/doc/selectors.hlp create mode 100644 pkg/utilities/nttools/threed/doc/tiimage.hlp create mode 100644 pkg/utilities/nttools/threed/doc/titable.hlp create mode 100644 pkg/utilities/nttools/threed/doc/tscopy.hlp create mode 100644 pkg/utilities/nttools/threed/doc/tximage.hlp create mode 100644 pkg/utilities/nttools/threed/doc/txtable.hlp create mode 100644 pkg/utilities/nttools/threed/mkpkg create mode 100644 pkg/utilities/nttools/threed/tblerr.h create mode 100644 pkg/utilities/nttools/threed/tbtables.h create mode 100644 pkg/utilities/nttools/threed/tiimage.par create mode 100644 pkg/utilities/nttools/threed/tiimage/design1.txt create mode 100644 pkg/utilities/nttools/threed/tiimage/generic/mkpkg create mode 100644 pkg/utilities/nttools/threed/tiimage/generic/tmcp1d.x create mode 100644 pkg/utilities/nttools/threed/tiimage/generic/tmcp1i.x create mode 100644 pkg/utilities/nttools/threed/tiimage/generic/tmcp1r.x create mode 100644 pkg/utilities/nttools/threed/tiimage/generic/tmcp1s.x create mode 100644 pkg/utilities/nttools/threed/tiimage/list.tex create mode 100644 pkg/utilities/nttools/threed/tiimage/list.toc create mode 100644 pkg/utilities/nttools/threed/tiimage/loc.txt create mode 100644 pkg/utilities/nttools/threed/tiimage/mkpkg create mode 100644 pkg/utilities/nttools/threed/tiimage/tiimage.h create mode 100644 pkg/utilities/nttools/threed/tiimage/tiimage.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmcopy.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmcp1.gx create mode 100644 pkg/utilities/nttools/threed/tiimage/tmhc.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmheader.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmloop.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmmode.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmscan.x create mode 100644 pkg/utilities/nttools/threed/titable.par create mode 100644 pkg/utilities/nttools/threed/titable/design1.txt create mode 100644 pkg/utilities/nttools/threed/titable/design2.txt create mode 100644 pkg/utilities/nttools/threed/titable/generic/mkpkg create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichb.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichc.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichd.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichi.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichr.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichs.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowsb.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowsc.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowsd.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowsi.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowsr.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowss.x create mode 100644 pkg/utilities/nttools/threed/titable/help.txt create mode 100644 pkg/utilities/nttools/threed/titable/list.tex create mode 100644 pkg/utilities/nttools/threed/titable/loc.txt create mode 100644 pkg/utilities/nttools/threed/titable/mkpkg create mode 100644 pkg/utilities/nttools/threed/titable/ticc.x create mode 100644 pkg/utilities/nttools/threed/titable/tich.gx create mode 100644 pkg/utilities/nttools/threed/titable/ticopy.x create mode 100644 pkg/utilities/nttools/threed/titable/tiheader.x create mode 100644 pkg/utilities/nttools/threed/titable/tinew.x create mode 100644 pkg/utilities/nttools/threed/titable/tinsert.x create mode 100644 pkg/utilities/nttools/threed/titable/tirows.gx create mode 100644 pkg/utilities/nttools/threed/titable/tisetc.x create mode 100644 pkg/utilities/nttools/threed/titable/titable.x create mode 100644 pkg/utilities/nttools/threed/titable/tiupdate.x create mode 100644 pkg/utilities/nttools/threed/tscopy.par create mode 100644 pkg/utilities/nttools/threed/tscopy/mkpkg create mode 100644 pkg/utilities/nttools/threed/tscopy/tbracket.x create mode 100644 pkg/utilities/nttools/threed/tscopy/tcpyone.x create mode 100644 pkg/utilities/nttools/threed/tscopy/tcpyrow.x create mode 100644 pkg/utilities/nttools/threed/tscopy/tscopy.x create mode 100644 pkg/utilities/nttools/threed/tximage.par create mode 100644 pkg/utilities/nttools/threed/tximage/mkpkg create mode 100644 pkg/utilities/nttools/threed/tximage/txicpy.x create mode 100644 pkg/utilities/nttools/threed/tximage/txihc.x create mode 100644 pkg/utilities/nttools/threed/tximage/tximage.x create mode 100644 pkg/utilities/nttools/threed/tximage/txione.x create mode 100644 pkg/utilities/nttools/threed/txtable.par create mode 100644 pkg/utilities/nttools/threed/txtable/generic/mkpkg create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcptb.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcptc.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcptd.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcpti.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcptr.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcpts.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvb.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvc.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvd.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvi.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvr.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvs.x create mode 100644 pkg/utilities/nttools/threed/txtable/mkpkg create mode 100644 pkg/utilities/nttools/threed/txtable/txtable.x create mode 100644 pkg/utilities/nttools/threed/txtable/txtcpt.gx create mode 100644 pkg/utilities/nttools/threed/txtable/txtcpy.x create mode 100644 pkg/utilities/nttools/threed/txtable/txtcpyco.x create mode 100644 pkg/utilities/nttools/threed/txtable/txtcpysc.x create mode 100644 pkg/utilities/nttools/threed/txtable/txthc.x create mode 100644 pkg/utilities/nttools/threed/txtable/txthv.gx create mode 100644 pkg/utilities/nttools/threed/txtable/txtone.x create mode 100644 pkg/utilities/nttools/threed/x_threed.x create mode 100644 pkg/utilities/nttools/thselect.par create mode 100644 pkg/utilities/nttools/tinfo.par create mode 100644 pkg/utilities/nttools/tinfo/mkpkg create mode 100644 pkg/utilities/nttools/tinfo/tinfo.x create mode 100644 pkg/utilities/nttools/tinfo/tlcol.x create mode 100644 pkg/utilities/nttools/tintegrate.par create mode 100644 pkg/utilities/nttools/tintegrate/mkpkg create mode 100644 pkg/utilities/nttools/tintegrate/tintegrate.x create mode 100644 pkg/utilities/nttools/tjoin.par create mode 100644 pkg/utilities/nttools/tjoin/closeiotab.x create mode 100644 pkg/utilities/nttools/tjoin/dojoin.x create mode 100644 pkg/utilities/nttools/tjoin/freetol.x create mode 100644 pkg/utilities/nttools/tjoin/isnumber.x create mode 100644 pkg/utilities/nttools/tjoin/issame.x create mode 100644 pkg/utilities/nttools/tjoin/mkjoin.x create mode 100644 pkg/utilities/nttools/tjoin/mkpkg create mode 100644 pkg/utilities/nttools/tjoin/openitab.x create mode 100644 pkg/utilities/nttools/tjoin/openotab.x create mode 100644 pkg/utilities/nttools/tjoin/readtol.x create mode 100644 pkg/utilities/nttools/tjoin/removejcol.x create mode 100644 pkg/utilities/nttools/tjoin/renamecol.x create mode 100644 pkg/utilities/nttools/tjoin/spptype.x create mode 100644 pkg/utilities/nttools/tjoin/tjoin.h create mode 100644 pkg/utilities/nttools/tjoin/tjoin.x create mode 100644 pkg/utilities/nttools/tlcol.par create mode 100644 pkg/utilities/nttools/tlinear.par create mode 100644 pkg/utilities/nttools/tlinear/mkpkg create mode 100644 pkg/utilities/nttools/tlinear/tlinear.x create mode 100644 pkg/utilities/nttools/tmatch.par create mode 100644 pkg/utilities/nttools/tmatch/getmatch.x create mode 100644 pkg/utilities/nttools/tmatch/getnorm.x create mode 100644 pkg/utilities/nttools/tmatch/getweight.x create mode 100644 pkg/utilities/nttools/tmatch/infomatch.x create mode 100644 pkg/utilities/nttools/tmatch/mkpkg create mode 100644 pkg/utilities/nttools/tmatch/putmatch.x create mode 100644 pkg/utilities/nttools/tmatch/rowname.x create mode 100644 pkg/utilities/nttools/tmatch/setindex.x create mode 100644 pkg/utilities/nttools/tmatch/sortclose.x create mode 100644 pkg/utilities/nttools/tmatch/sortdist.x create mode 100644 pkg/utilities/nttools/tmatch/tmatch.x create mode 100644 pkg/utilities/nttools/tmerge.par create mode 100644 pkg/utilities/nttools/tmerge/mkpkg create mode 100644 pkg/utilities/nttools/tmerge/tmerge.x create mode 100644 pkg/utilities/nttools/tprint.par create mode 100644 pkg/utilities/nttools/tprint/mkpkg create mode 100644 pkg/utilities/nttools/tprint/notes create mode 100644 pkg/utilities/nttools/tprint/tdump.x create mode 100644 pkg/utilities/nttools/tprint/tprhtml.x create mode 100644 pkg/utilities/nttools/tprint/tprint.h create mode 100644 pkg/utilities/nttools/tprint/tprint.x create mode 100644 pkg/utilities/nttools/tprint/tprlatex.x create mode 100644 pkg/utilities/nttools/tprint/tprplain.x create mode 100644 pkg/utilities/nttools/tproduct.par create mode 100644 pkg/utilities/nttools/tproduct/mkpkg create mode 100644 pkg/utilities/nttools/tproduct/tproduct.x create mode 100644 pkg/utilities/nttools/tproject.par create mode 100644 pkg/utilities/nttools/tproject/mkpkg create mode 100644 pkg/utilities/nttools/tproject/nextuniq.x create mode 100644 pkg/utilities/nttools/tproject/tproject.x create mode 100644 pkg/utilities/nttools/tproject/wproject.x create mode 100644 pkg/utilities/nttools/tquery.par create mode 100644 pkg/utilities/nttools/tquery/doquery.x create mode 100644 pkg/utilities/nttools/tquery/mkpkg create mode 100644 pkg/utilities/nttools/tquery/tquery.x create mode 100644 pkg/utilities/nttools/tquery/wquery.x create mode 100644 pkg/utilities/nttools/tread.par create mode 100644 pkg/utilities/nttools/trebin.par create mode 100644 pkg/utilities/nttools/trebin/mkpkg create mode 100644 pkg/utilities/nttools/trebin/tnamcls.x create mode 100644 pkg/utilities/nttools/trebin/tnamgio.x create mode 100644 pkg/utilities/nttools/trebin/tnaminit.x create mode 100644 pkg/utilities/nttools/trebin/trebin.h create mode 100644 pkg/utilities/nttools/trebin/trebin.x create mode 100644 pkg/utilities/nttools/trebin/tucspl.f create mode 100644 pkg/utilities/nttools/trebin/tudcol.x create mode 100644 pkg/utilities/nttools/trebin/tugcol.x create mode 100644 pkg/utilities/nttools/trebin/tugetput.x create mode 100644 pkg/utilities/nttools/trebin/tuhunt.f create mode 100644 pkg/utilities/nttools/trebin/tuiep3.f create mode 100644 pkg/utilities/nttools/trebin/tuifit.x create mode 100644 pkg/utilities/nttools/trebin/tuinterp.x create mode 100644 pkg/utilities/nttools/trebin/tuiset.x create mode 100644 pkg/utilities/nttools/trebin/tuispl.f create mode 100644 pkg/utilities/nttools/trebin/tuival.x create mode 100644 pkg/utilities/nttools/trebin/tutrim.x create mode 100644 pkg/utilities/nttools/trebin/tuxget.x create mode 100644 pkg/utilities/nttools/tselect.par create mode 100644 pkg/utilities/nttools/tselect/mkpkg create mode 100644 pkg/utilities/nttools/tselect/subset.x create mode 100644 pkg/utilities/nttools/tselect/tselect.x create mode 100644 pkg/utilities/nttools/tsort.par create mode 100644 pkg/utilities/nttools/tsort/mkpkg create mode 100644 pkg/utilities/nttools/tsort/tblextsort.x create mode 100644 pkg/utilities/nttools/tsort/tblintsort.x create mode 100644 pkg/utilities/nttools/tsort/tblmaxrow.x create mode 100644 pkg/utilities/nttools/tsort/tsort.x create mode 100644 pkg/utilities/nttools/tstat.par create mode 100644 pkg/utilities/nttools/tstat/mkpkg create mode 100644 pkg/utilities/nttools/tstat/thistogram.h create mode 100644 pkg/utilities/nttools/tstat/thistogram.x create mode 100644 pkg/utilities/nttools/tstat/thoptions.x create mode 100644 pkg/utilities/nttools/tstat/tstat.x create mode 100644 pkg/utilities/nttools/ttranspose.par create mode 100644 pkg/utilities/nttools/ttranspose/mkpkg create mode 100644 pkg/utilities/nttools/ttranspose/ttranspose.x create mode 100644 pkg/utilities/nttools/ttranspose/ttrflip.x create mode 100644 pkg/utilities/nttools/tunits.par create mode 100644 pkg/utilities/nttools/tunits/abrev.tab create mode 100644 pkg/utilities/nttools/tunits/abrev.x create mode 100644 pkg/utilities/nttools/tunits/convertcol.x create mode 100644 pkg/utilities/nttools/tunits/factor.x create mode 100644 pkg/utilities/nttools/tunits/mkpkg create mode 100644 pkg/utilities/nttools/tunits/parseunits.com create mode 100644 pkg/utilities/nttools/tunits/parseunits.x create mode 100644 pkg/utilities/nttools/tunits/parseunits.y create mode 100644 pkg/utilities/nttools/tunits/tuniterr.x create mode 100644 pkg/utilities/nttools/tunits/tunits.h create mode 100644 pkg/utilities/nttools/tunits/tunits.x create mode 100644 pkg/utilities/nttools/tunits/unhash.x create mode 100644 pkg/utilities/nttools/tunits/units.tab create mode 100644 pkg/utilities/nttools/tunits/units.x create mode 100644 pkg/utilities/nttools/tunits/unstr.x create mode 100644 pkg/utilities/nttools/tupar.par create mode 100644 pkg/utilities/nttools/tupar/mkpkg create mode 100644 pkg/utilities/nttools/tupar/tuinstr.x create mode 100644 pkg/utilities/nttools/tupar/tupar.h create mode 100644 pkg/utilities/nttools/tupar/tupar.x create mode 100644 pkg/utilities/nttools/x_nttools.x create mode 100644 pkg/utilities/nttools/zz.xml create mode 100644 pkg/utilities/nttools/zz_bad.xml create mode 100644 pkg/utilities/nttools/zz_rewrite.xml create mode 100644 pkg/utilities/pffctn.x create mode 100644 pkg/utilities/pfregres.f create mode 100644 pkg/utilities/polyfit.par create mode 100644 pkg/utilities/split.par create mode 100644 pkg/utilities/surfit.par create mode 100644 pkg/utilities/t_curfit.x create mode 100644 pkg/utilities/t_detab.x create mode 100644 pkg/utilities/t_entab.x create mode 100644 pkg/utilities/t_lcase.x create mode 100644 pkg/utilities/t_polyfit.x create mode 100644 pkg/utilities/t_split.x create mode 100644 pkg/utilities/t_surfit.x create mode 100644 pkg/utilities/t_translit.x create mode 100644 pkg/utilities/t_ucase.x create mode 100644 pkg/utilities/t_urand.x create mode 100644 pkg/utilities/translit.par create mode 100644 pkg/utilities/ucase.par create mode 100644 pkg/utilities/urand.par create mode 100644 pkg/utilities/utilities.cl create mode 100644 pkg/utilities/utilities.hd create mode 100644 pkg/utilities/utilities.men create mode 100644 pkg/utilities/utilities.par create mode 100644 pkg/utilities/x_utilities.x create mode 100644 pkg/vocl/Notes.ecl create mode 100644 pkg/vocl/Notes.samp create mode 100644 pkg/vocl/README create mode 100644 pkg/vocl/Revisions create mode 100644 pkg/vocl/TODO create mode 100644 pkg/vocl/_samp.cmds create mode 100644 pkg/vocl/_samp.funcs create mode 100644 pkg/vocl/binop.c create mode 100644 pkg/vocl/bkg.c create mode 100644 pkg/vocl/builtin.c create mode 100644 pkg/vocl/builtin_vo.c create mode 100755 pkg/vocl/cl.csh create mode 100755 pkg/vocl/cl.csh.SSOL create mode 100644 pkg/vocl/cl.par create mode 100644 pkg/vocl/clmodes.h create mode 100644 pkg/vocl/clprintf.c create mode 100644 pkg/vocl/clsamp.h create mode 100644 pkg/vocl/clsystem.c create mode 100644 pkg/vocl/compile.c create mode 100644 pkg/vocl/config.h create mode 100644 pkg/vocl/construct.h create mode 100644 pkg/vocl/debug.c create mode 100644 pkg/vocl/decl.c create mode 100644 pkg/vocl/doc/ecl.hlp create mode 100644 pkg/vocl/doc/pset.sys create mode 100755 pkg/vocl/ecl_install.csh create mode 100644 pkg/vocl/edcap.c create mode 100644 pkg/vocl/eparam.c create mode 100644 pkg/vocl/eparam.h create mode 100644 pkg/vocl/errs.c create mode 100644 pkg/vocl/errs.h create mode 100644 pkg/vocl/errtest/errif.cl create mode 100644 pkg/vocl/errtest/errtest.cl create mode 100644 pkg/vocl/errtest/errtest.hd create mode 100644 pkg/vocl/errtest/errtest.men create mode 100644 pkg/vocl/errtest/errtest.par create mode 100644 pkg/vocl/errtest/errtype.cl create mode 100644 pkg/vocl/errtest/mkpkg create mode 100644 pkg/vocl/errtest/nest0.cl create mode 100644 pkg/vocl/errtest/nested.cl create mode 100644 pkg/vocl/errtest/printvals.cl create mode 100644 pkg/vocl/errtest/recur0.cl create mode 100644 pkg/vocl/errtest/recursion.cl create mode 100644 pkg/vocl/errtest/sfpe.cl create mode 100644 pkg/vocl/errtest/spperrs.x create mode 100644 pkg/vocl/errtest/test_iferr.cl create mode 100644 pkg/vocl/errtest/zztest.cl create mode 100644 pkg/vocl/exec.c create mode 100644 pkg/vocl/globals.c create mode 100644 pkg/vocl/gquery.c create mode 100644 pkg/vocl/gram.c create mode 100644 pkg/vocl/grammar.h create mode 100644 pkg/vocl/grammar.l create mode 100644 pkg/vocl/grammar.y create mode 100644 pkg/vocl/history.c create mode 100644 pkg/vocl/lex.com create mode 100644 pkg/vocl/lex.sed create mode 100644 pkg/vocl/lexicon.c create mode 100644 pkg/vocl/lexyy.c create mode 100644 pkg/vocl/lists.c create mode 100644 pkg/vocl/login.cl create mode 100644 pkg/vocl/logout.cl create mode 100644 pkg/vocl/main.c create mode 100644 pkg/vocl/mem.h create mode 100755 pkg/vocl/mkdist create mode 100644 pkg/vocl/mkpkg create mode 100644 pkg/vocl/modes.c create mode 100644 pkg/vocl/multop.c create mode 100644 pkg/vocl/opcodes.c create mode 100644 pkg/vocl/opcodes.h create mode 100644 pkg/vocl/operand.c create mode 100644 pkg/vocl/operand.h create mode 100644 pkg/vocl/param.c create mode 100644 pkg/vocl/param.h create mode 100644 pkg/vocl/pfiles.c create mode 100644 pkg/vocl/prcache.c create mode 100644 pkg/vocl/proto.h create mode 100644 pkg/vocl/samp.c create mode 100644 pkg/vocl/sampCmd.c create mode 100644 pkg/vocl/sampDecl.h create mode 100644 pkg/vocl/sampFuncs.c create mode 100644 pkg/vocl/sampHandlers.c create mode 100644 pkg/vocl/scan.c create mode 100644 pkg/vocl/stack.c create mode 100644 pkg/vocl/tags create mode 100644 pkg/vocl/task.c create mode 100644 pkg/vocl/task.h create mode 100644 pkg/vocl/unop.c create mode 100644 pkg/vocl/uparm/history.cl create mode 100644 pkg/vocl/uparm/usrtest.par create mode 100644 pkg/vocl/vocl.x create mode 100644 pkg/vocl/voclient.c create mode 100644 pkg/vocl/voclient.h create mode 100644 pkg/vocl/y.output create mode 100644 pkg/vocl/ytab.c create mode 100644 pkg/vocl/ytab.h create mode 100644 pkg/xtools/README create mode 100644 pkg/xtools/Revisions create mode 100644 pkg/xtools/catquery/cq.h create mode 100644 pkg/xtools/catquery/cqdb.x create mode 100644 pkg/xtools/catquery/cqdef.h create mode 100644 pkg/xtools/catquery/cqdtype.x create mode 100644 pkg/xtools/catquery/cqget.x create mode 100644 pkg/xtools/catquery/cqgfields.x create mode 100644 pkg/xtools/catquery/cqgqpars.x create mode 100644 pkg/xtools/catquery/cqgrecords.x create mode 100644 pkg/xtools/catquery/cqiminfo.x create mode 100644 pkg/xtools/catquery/cqimquery.x create mode 100644 pkg/xtools/catquery/cqistat.x create mode 100644 pkg/xtools/catquery/cqlocate.x create mode 100644 pkg/xtools/catquery/cqmap.x create mode 100644 pkg/xtools/catquery/cqnqpars.x create mode 100644 pkg/xtools/catquery/cqquery.x create mode 100644 pkg/xtools/catquery/cqrinfo.x create mode 100644 pkg/xtools/catquery/cqrstat.x create mode 100644 pkg/xtools/catquery/cqsetcat.x create mode 100644 pkg/xtools/catquery/cqsqpars.x create mode 100644 pkg/xtools/catquery/cqstat.x create mode 100644 pkg/xtools/catquery/cqwrdstr.x create mode 100644 pkg/xtools/catquery/doc/README create mode 100644 pkg/xtools/catquery/doc/catalogs.hlp create mode 100644 pkg/xtools/catquery/doc/catquery.hd create mode 100644 pkg/xtools/catquery/doc/catquery.hlp create mode 100644 pkg/xtools/catquery/doc/catquery.men create mode 100644 pkg/xtools/catquery/doc/ccsystems.hlp create mode 100644 pkg/xtools/catquery/doc/cqfimquery.hlp create mode 100644 pkg/xtools/catquery/doc/cqfinfo.hlp create mode 100644 pkg/xtools/catquery/doc/cqfinfon.hlp create mode 100644 pkg/xtools/catquery/doc/cqfquery.hlp create mode 100644 pkg/xtools/catquery/doc/cqget.hlp create mode 100644 pkg/xtools/catquery/doc/cqgnrecord.hlp create mode 100644 pkg/xtools/catquery/doc/cqgqpar.hlp create mode 100644 pkg/xtools/catquery/doc/cqgqparn.hlp create mode 100644 pkg/xtools/catquery/doc/cqgrecord.hlp create mode 100644 pkg/xtools/catquery/doc/cqgvalc.hlp create mode 100644 pkg/xtools/catquery/doc/cqgvald.hlp create mode 100644 pkg/xtools/catquery/doc/cqgvali.hlp create mode 100644 pkg/xtools/catquery/doc/cqgvall.hlp create mode 100644 pkg/xtools/catquery/doc/cqgvalr.hlp create mode 100644 pkg/xtools/catquery/doc/cqgvals.hlp create mode 100644 pkg/xtools/catquery/doc/cqhinfo.hlp create mode 100644 pkg/xtools/catquery/doc/cqhinfon.hlp create mode 100644 pkg/xtools/catquery/doc/cqimclose.hlp create mode 100644 pkg/xtools/catquery/doc/cqimquery.hlp create mode 100644 pkg/xtools/catquery/doc/cqistati.hlp create mode 100644 pkg/xtools/catquery/doc/cqistats.hlp create mode 100644 pkg/xtools/catquery/doc/cqistatt.hlp create mode 100644 pkg/xtools/catquery/doc/cqkinfo.hlp create mode 100644 pkg/xtools/catquery/doc/cqkinfon.hlp create mode 100644 pkg/xtools/catquery/doc/cqlocate.hlp create mode 100644 pkg/xtools/catquery/doc/cqlocaten.hlp create mode 100644 pkg/xtools/catquery/doc/cqmap.hlp create mode 100644 pkg/xtools/catquery/doc/cqnqpars.hlp create mode 100644 pkg/xtools/catquery/doc/cqquery.hlp create mode 100644 pkg/xtools/catquery/doc/cqrclose.hlp create mode 100644 pkg/xtools/catquery/doc/cqrstati.hlp create mode 100644 pkg/xtools/catquery/doc/cqrstats.hlp create mode 100644 pkg/xtools/catquery/doc/cqrstatt.hlp create mode 100644 pkg/xtools/catquery/doc/cqsetcat.hlp create mode 100644 pkg/xtools/catquery/doc/cqsetcatn.hlp create mode 100644 pkg/xtools/catquery/doc/cqsqpar.hlp create mode 100644 pkg/xtools/catquery/doc/cqsqparn.hlp create mode 100644 pkg/xtools/catquery/doc/cqstati.hlp create mode 100644 pkg/xtools/catquery/doc/cqstats.hlp create mode 100644 pkg/xtools/catquery/doc/cqstatt.hlp create mode 100644 pkg/xtools/catquery/doc/cqunmap.hlp create mode 100644 pkg/xtools/catquery/doc/cqwinfo.hlp create mode 100644 pkg/xtools/catquery/doc/cqwinfon.hlp create mode 100644 pkg/xtools/catquery/doc/surveys.hlp create mode 100644 pkg/xtools/catquery/mkpkg create mode 100644 pkg/xtools/center1d.h create mode 100644 pkg/xtools/center1d.x create mode 100644 pkg/xtools/clgcurfit.x create mode 100644 pkg/xtools/clginterp.x create mode 100644 pkg/xtools/clgsec.x create mode 100644 pkg/xtools/cogetr.h create mode 100644 pkg/xtools/cogetr.x create mode 100644 pkg/xtools/doc/Notes create mode 100644 pkg/xtools/doc/center1d.hlp create mode 100644 pkg/xtools/doc/cogetr.hlp create mode 100644 pkg/xtools/doc/extrema.hlp create mode 100644 pkg/xtools/doc/inlfit.hlp create mode 100644 pkg/xtools/doc/peaks.hlp create mode 100644 pkg/xtools/doc/ranges.hlp create mode 100644 pkg/xtools/doc/xtextns.hlp create mode 100644 pkg/xtools/doc/xtmaskname.hlp create mode 100644 pkg/xtools/doc/xtools.hd create mode 100644 pkg/xtools/doc/xtools.men create mode 100644 pkg/xtools/doc/xtpmmap.hlp create mode 100644 pkg/xtools/doc/xtsums.hlp create mode 100644 pkg/xtools/dttext.x create mode 100644 pkg/xtools/extrema.x create mode 100644 pkg/xtools/fixpix/mkpkg create mode 100644 pkg/xtools/fixpix/setfp.x create mode 100644 pkg/xtools/fixpix/xtfixpix.h create mode 100644 pkg/xtools/fixpix/xtfixpix.x create mode 100644 pkg/xtools/fixpix/xtfp.gx create mode 100644 pkg/xtools/fixpix/xtfp.x create mode 100644 pkg/xtools/fixpix/xtpmmap.x create mode 100644 pkg/xtools/fixpix/ytfixpix.x create mode 100644 pkg/xtools/fixpix/ytpmmap.x create mode 100644 pkg/xtools/getdatatype.x create mode 100644 pkg/xtools/gstrdetab.x create mode 100644 pkg/xtools/gstrentab.x create mode 100644 pkg/xtools/gstrsettab.x create mode 100644 pkg/xtools/gtools/Revisions create mode 100644 pkg/xtools/gtools/gtascale.x create mode 100644 pkg/xtools/gtools/gtcolon.x create mode 100644 pkg/xtools/gtools/gtcopy.x create mode 100644 pkg/xtools/gtools/gtctran.x create mode 100644 pkg/xtools/gtools/gtcur.x create mode 100644 pkg/xtools/gtools/gtcur1.x create mode 100644 pkg/xtools/gtools/gtfree.x create mode 100644 pkg/xtools/gtools/gtget.x create mode 100644 pkg/xtools/gtools/gtgui.x create mode 100644 pkg/xtools/gtools/gthelp.x create mode 100644 pkg/xtools/gtools/gtinit.x create mode 100644 pkg/xtools/gtools/gtlabax.x create mode 100644 pkg/xtools/gtools/gtools.h create mode 100644 pkg/xtools/gtools/gtools.hd create mode 100644 pkg/xtools/gtools/gtools.hlp create mode 100644 pkg/xtools/gtools/gtplot.x create mode 100644 pkg/xtools/gtools/gtreset.x create mode 100644 pkg/xtools/gtools/gtset.x create mode 100644 pkg/xtools/gtools/gtswind.x create mode 100644 pkg/xtools/gtools/gtvplot.x create mode 100644 pkg/xtools/gtools/gtwindow.x create mode 100644 pkg/xtools/gtools/mkpkg create mode 100644 pkg/xtools/icfit/Revisions create mode 100644 pkg/xtools/icfit/icclean.gx create mode 100644 pkg/xtools/icfit/iccleand.x create mode 100644 pkg/xtools/icfit/iccleanr.x create mode 100644 pkg/xtools/icfit/icdeviant.gx create mode 100644 pkg/xtools/icfit/icdeviantd.x create mode 100644 pkg/xtools/icfit/icdeviantr.x create mode 100644 pkg/xtools/icfit/icdosetup.gx create mode 100644 pkg/xtools/icfit/icdosetupd.x create mode 100644 pkg/xtools/icfit/icdosetupr.x create mode 100644 pkg/xtools/icfit/icerrors.gx create mode 100644 pkg/xtools/icfit/icerrorsd.x create mode 100644 pkg/xtools/icfit/icerrorsr.x create mode 100644 pkg/xtools/icfit/icferrors.gx create mode 100644 pkg/xtools/icfit/icferrorsd.x create mode 100644 pkg/xtools/icfit/icferrorsr.x create mode 100644 pkg/xtools/icfit/icfit.gx create mode 100644 pkg/xtools/icfit/icfit.h create mode 100644 pkg/xtools/icfit/icfit.hlp create mode 100644 pkg/xtools/icfit/icfitd.x create mode 100644 pkg/xtools/icfit/icfitr.x create mode 100644 pkg/xtools/icfit/icfshow.x create mode 100644 pkg/xtools/icfit/icfvshow.gx create mode 100644 pkg/xtools/icfit/icfvshowd.x create mode 100644 pkg/xtools/icfit/icfvshowr.x create mode 100644 pkg/xtools/icfit/icgadd.gx create mode 100644 pkg/xtools/icfit/icgaddd.x create mode 100644 pkg/xtools/icfit/icgaddr.x create mode 100644 pkg/xtools/icfit/icgaxes.gx create mode 100644 pkg/xtools/icfit/icgaxesd.x create mode 100644 pkg/xtools/icfit/icgaxesr.x create mode 100644 pkg/xtools/icfit/icgcolon.gx create mode 100644 pkg/xtools/icfit/icgcolond.x create mode 100644 pkg/xtools/icfit/icgcolonr.x create mode 100644 pkg/xtools/icfit/icgdelete.gx create mode 100644 pkg/xtools/icfit/icgdeleted.x create mode 100644 pkg/xtools/icfit/icgdeleter.x create mode 100644 pkg/xtools/icfit/icgfit.gx create mode 100644 pkg/xtools/icfit/icgfitd.x create mode 100644 pkg/xtools/icfit/icgfitr.x create mode 100644 pkg/xtools/icfit/icggraph.gx create mode 100644 pkg/xtools/icfit/icggraphd.x create mode 100644 pkg/xtools/icfit/icggraphr.x create mode 100644 pkg/xtools/icfit/icgnearest.gx create mode 100644 pkg/xtools/icfit/icgnearestd.x create mode 100644 pkg/xtools/icfit/icgnearestr.x create mode 100644 pkg/xtools/icfit/icgparams.gx create mode 100644 pkg/xtools/icfit/icgparamsd.x create mode 100644 pkg/xtools/icfit/icgparamsr.x create mode 100644 pkg/xtools/icfit/icgsample.gx create mode 100644 pkg/xtools/icfit/icgsampled.x create mode 100644 pkg/xtools/icfit/icgsampler.x create mode 100644 pkg/xtools/icfit/icguaxes.gx create mode 100644 pkg/xtools/icfit/icguaxesd.x create mode 100644 pkg/xtools/icfit/icguaxesr.x create mode 100644 pkg/xtools/icfit/icgui.x create mode 100644 pkg/xtools/icfit/icguishow.gx create mode 100644 pkg/xtools/icfit/icguishowd.x create mode 100644 pkg/xtools/icfit/icguishowr.x create mode 100644 pkg/xtools/icfit/icgundelete.gx create mode 100644 pkg/xtools/icfit/icgundeleted.x create mode 100644 pkg/xtools/icfit/icgundeleter.x create mode 100644 pkg/xtools/icfit/icguser.x create mode 100644 pkg/xtools/icfit/iclist.gx create mode 100644 pkg/xtools/icfit/iclistd.x create mode 100644 pkg/xtools/icfit/iclistr.x create mode 100644 pkg/xtools/icfit/icparams.x create mode 100644 pkg/xtools/icfit/icreject.gx create mode 100644 pkg/xtools/icfit/icrejectd.x create mode 100644 pkg/xtools/icfit/icrejectr.x create mode 100644 pkg/xtools/icfit/icshow.x create mode 100644 pkg/xtools/icfit/icvshow.gx create mode 100644 pkg/xtools/icfit/icvshowd.x create mode 100644 pkg/xtools/icfit/icvshowr.x create mode 100644 pkg/xtools/icfit/mkpkg create mode 100644 pkg/xtools/icfit/names.h create mode 100644 pkg/xtools/imtools.x create mode 100644 pkg/xtools/inlfit/README create mode 100644 pkg/xtools/inlfit/incopy.gx create mode 100644 pkg/xtools/inlfit/incopyd.x create mode 100644 pkg/xtools/inlfit/incopyr.x create mode 100644 pkg/xtools/inlfit/indeviant.gx create mode 100644 pkg/xtools/inlfit/indeviantd.x create mode 100644 pkg/xtools/inlfit/indeviantr.x create mode 100644 pkg/xtools/inlfit/indump.gx create mode 100644 pkg/xtools/inlfit/indumpd.x create mode 100644 pkg/xtools/inlfit/indumpr.x create mode 100644 pkg/xtools/inlfit/inerrors.gx create mode 100644 pkg/xtools/inlfit/inerrorsd.x create mode 100644 pkg/xtools/inlfit/inerrorsr.x create mode 100644 pkg/xtools/inlfit/infit.gx create mode 100644 pkg/xtools/inlfit/infitd.x create mode 100644 pkg/xtools/inlfit/infitr.x create mode 100644 pkg/xtools/inlfit/infree.gx create mode 100644 pkg/xtools/inlfit/infreed.x create mode 100644 pkg/xtools/inlfit/infreer.x create mode 100644 pkg/xtools/inlfit/ingaxes.gx create mode 100644 pkg/xtools/inlfit/ingaxesd.x create mode 100644 pkg/xtools/inlfit/ingaxesr.x create mode 100644 pkg/xtools/inlfit/ingcolon.gx create mode 100644 pkg/xtools/inlfit/ingcolond.x create mode 100644 pkg/xtools/inlfit/ingcolonr.x create mode 100644 pkg/xtools/inlfit/ingdata.gx create mode 100644 pkg/xtools/inlfit/ingdatad.x create mode 100644 pkg/xtools/inlfit/ingdatar.x create mode 100644 pkg/xtools/inlfit/ingdefkey.x create mode 100644 pkg/xtools/inlfit/ingdelete.gx create mode 100644 pkg/xtools/inlfit/ingdeleted.x create mode 100644 pkg/xtools/inlfit/ingdeleter.x create mode 100644 pkg/xtools/inlfit/ingerrors.gx create mode 100644 pkg/xtools/inlfit/ingerrorsd.x create mode 100644 pkg/xtools/inlfit/ingerrorsr.x create mode 100644 pkg/xtools/inlfit/inget.gx create mode 100644 pkg/xtools/inlfit/inget.x create mode 100644 pkg/xtools/inlfit/ingfit.gx create mode 100644 pkg/xtools/inlfit/ingfitd.x create mode 100644 pkg/xtools/inlfit/ingfitr.x create mode 100644 pkg/xtools/inlfit/inggetlabel.x create mode 100644 pkg/xtools/inlfit/inggraph.gx create mode 100644 pkg/xtools/inlfit/inggraphd.x create mode 100644 pkg/xtools/inlfit/inggraphr.x create mode 100644 pkg/xtools/inlfit/ingnearest.gx create mode 100644 pkg/xtools/inlfit/ingnearestd.x create mode 100644 pkg/xtools/inlfit/ingnearestr.x create mode 100644 pkg/xtools/inlfit/ingparams.gx create mode 100644 pkg/xtools/inlfit/ingparamsd.x create mode 100644 pkg/xtools/inlfit/ingparamsr.x create mode 100644 pkg/xtools/inlfit/ingresults.gx create mode 100644 pkg/xtools/inlfit/ingresultsd.x create mode 100644 pkg/xtools/inlfit/ingresultsr.x create mode 100644 pkg/xtools/inlfit/ingshow.gx create mode 100644 pkg/xtools/inlfit/ingshowd.x create mode 100644 pkg/xtools/inlfit/ingshowr.x create mode 100644 pkg/xtools/inlfit/ingtitle.x create mode 100644 pkg/xtools/inlfit/inguaxes.gx create mode 100644 pkg/xtools/inlfit/inguaxesd.x create mode 100644 pkg/xtools/inlfit/inguaxesr.x create mode 100644 pkg/xtools/inlfit/ingucolon.gx create mode 100644 pkg/xtools/inlfit/ingucolond.x create mode 100644 pkg/xtools/inlfit/ingucolonr.x create mode 100644 pkg/xtools/inlfit/ingufit.x create mode 100644 pkg/xtools/inlfit/ingundelete.gx create mode 100644 pkg/xtools/inlfit/ingundeleted.x create mode 100644 pkg/xtools/inlfit/ingundeleter.x create mode 100644 pkg/xtools/inlfit/ingvars.gx create mode 100644 pkg/xtools/inlfit/ingvarsd.x create mode 100644 pkg/xtools/inlfit/ingvarsr.x create mode 100644 pkg/xtools/inlfit/ingvshow.gx create mode 100644 pkg/xtools/inlfit/ingvshowd.x create mode 100644 pkg/xtools/inlfit/ingvshowr.x create mode 100644 pkg/xtools/inlfit/ininit.gx create mode 100644 pkg/xtools/inlfit/ininitd.x create mode 100644 pkg/xtools/inlfit/ininitr.x create mode 100644 pkg/xtools/inlfit/inlfitdef.h create mode 100644 pkg/xtools/inlfit/inlgfit.key create mode 100644 pkg/xtools/inlfit/inlimit.gx create mode 100644 pkg/xtools/inlfit/inlimitd.x create mode 100644 pkg/xtools/inlfit/inlimitr.x create mode 100644 pkg/xtools/inlfit/inlstrext.x create mode 100644 pkg/xtools/inlfit/inlstrwrd.x create mode 100644 pkg/xtools/inlfit/innlinit.gx create mode 100644 pkg/xtools/inlfit/innlinitd.x create mode 100644 pkg/xtools/inlfit/innlinitr.x create mode 100644 pkg/xtools/inlfit/input.gx create mode 100644 pkg/xtools/inlfit/input.x create mode 100644 pkg/xtools/inlfit/inrefit.gx create mode 100644 pkg/xtools/inlfit/inrefitd.x create mode 100644 pkg/xtools/inlfit/inrefitr.x create mode 100644 pkg/xtools/inlfit/inreject.gx create mode 100644 pkg/xtools/inlfit/inrejectd.x create mode 100644 pkg/xtools/inlfit/inrejectr.x create mode 100644 pkg/xtools/inlfit/inrms.gx create mode 100644 pkg/xtools/inlfit/inrmsd.x create mode 100644 pkg/xtools/inlfit/inrmsr.x create mode 100644 pkg/xtools/inlfit/mkpkg create mode 100644 pkg/xtools/intrp.f create mode 100644 pkg/xtools/isdir.x create mode 100644 pkg/xtools/mef/Notes create mode 100644 pkg/xtools/mef/mefappfile.x create mode 100644 pkg/xtools/mef/mefclose.x create mode 100644 pkg/xtools/mef/mefcpextn.x create mode 100644 pkg/xtools/mef/mefdummyh.x create mode 100644 pkg/xtools/mef/mefencode.x create mode 100644 pkg/xtools/mef/mefget.x create mode 100644 pkg/xtools/mef/mefgnbc.x create mode 100644 pkg/xtools/mef/mefgval.x create mode 100644 pkg/xtools/mef/mefkfind.x create mode 100644 pkg/xtools/mef/mefksection.x create mode 100644 pkg/xtools/mef/mefldhdr.x create mode 100644 pkg/xtools/mef/mefopen.x create mode 100644 pkg/xtools/mef/mefrdhdr.x create mode 100644 pkg/xtools/mef/mefrdhdr.x_save create mode 100644 pkg/xtools/mef/mefsetpl.x create mode 100644 pkg/xtools/mef/mefwrhdr.x create mode 100644 pkg/xtools/mef/mefwrhdr.x_save create mode 100644 pkg/xtools/mef/mefwrpl.x create mode 100644 pkg/xtools/mef/mkpkg create mode 100644 pkg/xtools/mkpkg create mode 100644 pkg/xtools/numrecipes.x create mode 100644 pkg/xtools/obsdb.x create mode 100644 pkg/xtools/peaks.x create mode 100644 pkg/xtools/ranges.par create mode 100644 pkg/xtools/ranges.x create mode 100644 pkg/xtools/ranges/Revisions create mode 100644 pkg/xtools/ranges/mkpkg create mode 100644 pkg/xtools/ranges/rgbin.gx create mode 100644 pkg/xtools/ranges/rgbind.x create mode 100644 pkg/xtools/ranges/rgbinr.x create mode 100644 pkg/xtools/ranges/rgdump.x create mode 100644 pkg/xtools/ranges/rgencode.x create mode 100644 pkg/xtools/ranges/rgexclude.gx create mode 100644 pkg/xtools/ranges/rgexcluded.x create mode 100644 pkg/xtools/ranges/rgexcluder.x create mode 100644 pkg/xtools/ranges/rgfree.x create mode 100644 pkg/xtools/ranges/rggxmark.gx create mode 100644 pkg/xtools/ranges/rggxmarkd.x create mode 100644 pkg/xtools/ranges/rggxmarkr.x create mode 100644 pkg/xtools/ranges/rgindices.x create mode 100644 pkg/xtools/ranges/rginrange.x create mode 100644 pkg/xtools/ranges/rgintersect.x create mode 100644 pkg/xtools/ranges/rginverse.x create mode 100644 pkg/xtools/ranges/rgmerge.x create mode 100644 pkg/xtools/ranges/rgnext.x create mode 100644 pkg/xtools/ranges/rgorder.x create mode 100644 pkg/xtools/ranges/rgpack.gx create mode 100644 pkg/xtools/ranges/rgpackd.x create mode 100644 pkg/xtools/ranges/rgpackr.x create mode 100644 pkg/xtools/ranges/rgranges.x create mode 100644 pkg/xtools/ranges/rgunion.x create mode 100644 pkg/xtools/ranges/rgunpack.gx create mode 100644 pkg/xtools/ranges/rgunpackd.x create mode 100644 pkg/xtools/ranges/rgunpackr.x create mode 100644 pkg/xtools/ranges/rgwindow.x create mode 100644 pkg/xtools/ranges/rgwtbin.gx create mode 100644 pkg/xtools/ranges/rgwtbind.x create mode 100644 pkg/xtools/ranges/rgwtbinr.x create mode 100644 pkg/xtools/ranges/rgxranges.gx create mode 100644 pkg/xtools/ranges/rgxranges1.gx create mode 100644 pkg/xtools/ranges/rgxrangesd.x create mode 100644 pkg/xtools/ranges/rgxrangesr.x create mode 100644 pkg/xtools/rmmed.x create mode 100644 pkg/xtools/rmsorted.x create mode 100644 pkg/xtools/rmturlach.x create mode 100644 pkg/xtools/rngranges.x create mode 100644 pkg/xtools/rngranges.xBAK create mode 100644 pkg/xtools/skywcs/doc/README create mode 100644 pkg/xtools/skywcs/doc/ccsystems.hlp create mode 100644 pkg/xtools/skywcs/doc/skclose.hlp create mode 100644 pkg/xtools/skywcs/doc/skcopy.hlp create mode 100644 pkg/xtools/skywcs/doc/skdecim.hlp create mode 100644 pkg/xtools/skywcs/doc/skdecwcs.hlp create mode 100644 pkg/xtools/skywcs/doc/skdecwstr.hlp create mode 100644 pkg/xtools/skywcs/doc/skenwcs.hlp create mode 100644 pkg/xtools/skywcs/doc/skequatorial.hlp create mode 100644 pkg/xtools/skywcs/doc/skiiprint.hlp create mode 100644 pkg/xtools/skywcs/doc/skiiwrite.hlp create mode 100644 pkg/xtools/skywcs/doc/sklltran.hlp create mode 100644 pkg/xtools/skywcs/doc/sksaveim.hlp create mode 100644 pkg/xtools/skywcs/doc/sksetd.hlp create mode 100644 pkg/xtools/skywcs/doc/skseti.hlp create mode 100644 pkg/xtools/skywcs/doc/sksets.hlp create mode 100644 pkg/xtools/skywcs/doc/skstatd.hlp create mode 100644 pkg/xtools/skywcs/doc/skstati.hlp create mode 100644 pkg/xtools/skywcs/doc/skstats.hlp create mode 100644 pkg/xtools/skywcs/doc/skultran.hlp create mode 100644 pkg/xtools/skywcs/doc/skywcs.hd create mode 100644 pkg/xtools/skywcs/doc/skywcs.hlp create mode 100644 pkg/xtools/skywcs/doc/skywcs.men create mode 100644 pkg/xtools/skywcs/mkpkg create mode 100644 pkg/xtools/skywcs/skdecode.x create mode 100644 pkg/xtools/skywcs/sksaveim.x create mode 100644 pkg/xtools/skywcs/skset.x create mode 100644 pkg/xtools/skywcs/skstat.x create mode 100644 pkg/xtools/skywcs/sktransform.x create mode 100644 pkg/xtools/skywcs/skwrdstr.x create mode 100644 pkg/xtools/skywcs/skwrite.x create mode 100644 pkg/xtools/skywcs/skywcs.h create mode 100644 pkg/xtools/skywcs/skywcsdef.h create mode 100644 pkg/xtools/strdetab.x create mode 100644 pkg/xtools/strentab.x create mode 100644 pkg/xtools/syshost.x create mode 100644 pkg/xtools/t_txtcompile.x create mode 100755 pkg/xtools/txtcompile create mode 100644 pkg/xtools/xt21imsum.x create mode 100644 pkg/xtools/xtanswer.h create mode 100644 pkg/xtools/xtanswer.x create mode 100644 pkg/xtools/xtargs.x create mode 100644 pkg/xtools/xtbitarray.x create mode 100644 pkg/xtools/xtextns.x create mode 100644 pkg/xtools/xtgids.x create mode 100644 pkg/xtools/xtimleneq.x create mode 100644 pkg/xtools/xtimnames.x create mode 100644 pkg/xtools/xtimtgetim.x create mode 100644 pkg/xtools/xtlogfiles.x create mode 100644 pkg/xtools/xtmaskname.x create mode 100644 pkg/xtools/xtmksection.x create mode 100644 pkg/xtools/xtphistory.x create mode 100644 pkg/xtools/xtsample.gx create mode 100644 pkg/xtools/xtsample.x create mode 100644 pkg/xtools/xtsort.x create mode 100644 pkg/xtools/xtstat.gx create mode 100644 pkg/xtools/xtstat.x create mode 100644 pkg/xtools/xtstripwhite.x create mode 100644 pkg/xtools/xtsums.x create mode 100644 pkg/xtools/xttxtfio.x create mode 100644 pkg/xtools/zzdebug.x (limited to 'pkg') diff --git a/pkg/README b/pkg/README new file mode 100644 index 00000000..a32ec3e0 --- /dev/null +++ b/pkg/README @@ -0,0 +1,18 @@ +These directories contain the source, documentation, and default parameter +files for all IRAF system packages. + + cl The command language + dataio Data format conversions (FITS, card image, etc.) + dbms Database management utilities + images General image processing and display + language CL language stuff (task, kill, set, etc.) + lists List processing utilities + obsolete Obsolete tasks to be phased out + plot General plotting utilities + proto Prototype tasks + softools Software tools + system System utilities (files etc.) + utilities Miscellaneous utilities + + xtools Applications tools library + bench Benchmarks package (not an installed package) diff --git a/pkg/bench/README b/pkg/bench/README new file mode 100644 index 00000000..0e892171 --- /dev/null +++ b/pkg/bench/README @@ -0,0 +1,2 @@ +BENCH -- IRAF benchmarks package. Documented in the bench.hlp file in this +directory. diff --git a/pkg/bench/bench.cl b/pkg/bench/bench.cl new file mode 100644 index 00000000..9a84da27 --- /dev/null +++ b/pkg/bench/bench.cl @@ -0,0 +1,23 @@ +images +plot + +#{ BENCH -- Benchmarks package. + +package bench + +set bench = "pkg$bench/" + +task fortask = "bench$fortask.cl" +task subproc = "bench$subproc.cl" +task plots = "bench$plots.cl" + +task $ptime, + $getpar, + $wipc.bb, + $rrbin, + $rbin, + $wbin, + $rtext, + $wtext = "bench$x_bench.e" + +clbye() diff --git a/pkg/bench/bench.hlp b/pkg/bench/bench.hlp new file mode 100644 index 00000000..3b7a97b9 --- /dev/null +++ b/pkg/bench/bench.hlp @@ -0,0 +1,1723 @@ +.help bench Mar86 "IRAF Performance Tests" +.ce +\fBA Set of Benchmarks for Measuring IRAF System Performance\fR +.ce +Doug Tody +.ce +March 28, 1986 +.ce +(Revised July 1987) + +.nh +Introduction + + This set of benchmarks has been prepared with a number of purposes in mind. +Firstly, the benchmarks may be run after installing IRAF on a new system to +verify that the performance expected for that machine is actually being +achieved. In general, this cannot be taken for granted since the performance +actually achieved on a particular system can be highly dependent upon how the +system is configured and tuned. Secondly, the benchmarks may be run to compare +the performance of different IRAF hosts, or to track the system performance +over a period of time as improvements are made, both to IRAF and to the host +system. Lastly, the benchmarks provide a metric which can be used to tune +the host system. + +All too often, the only benchmarks run on a system are those which test the +execution time of optimized code generated by the host Fortran compiler. +This is primarily a hardware benchmark and secondarily a test of the Fortran +optimizer. An example of this type of test is the famous Linpack benchmark. + +The numerical execution speed test is an important benchmark but it tests only +one of the many factors contributing to the overall performance of the system +as perceived by the user. In interactive use other factors are often more +important, e.g., the time required to spawn or communicate with a subprocess, +the time required to access a file, the response of the system as the number +of users (or processes) increases, and so on. While the quality of optimized +code is a critical factor for cpu intensive batch processing, other factors +are often more important for sophisticated interactive applications. + +The benchmarks described here are designed to test, as fully as possible, +the major factors contributing to the overall performance of the IRAF system +on a particular host. A major factor in the timings of each benchmark is +of course the IRAF system itself, but comparisons of different hosts are +nonetheless possible since the code is virtually identical on all hosts. +The IRAF kernel is coded differently for each host, but the functions +performed by the kernel are identical on each host, and in most cases the +kernel operations are a negligible factor in the final timings. + +The IRAF version number, host operating system and associated version number, +and the host computer hardware configuration are all important in interpreting +the results of the benchmarks, and should always be recorded. + +.nh +What is Measured + + Each benchmark measures two quantities, the total cpu time required to +execute the benchmark, and the total (wall) clock time required to execute the +benchmark. If the clock time measurement is to be of any value the benchmarks +must be run on a single user system. Given this "best time" measurement, +it is not difficult to predict the performance to be expected on a loaded +system. + +The total cpu time required to execute a benchmark consists of the "user" time +plus the "system" time. The "user" time is the cpu time spent executing +the instructions comprising the user program. The "system" time is the cpu +time spent in kernel mode executing the system services called by the user +program. When possible we give both measurements, while in some cases only +the user time is given, or only the sum of the user and system times. +If the benchmark involves several concurrent processes no cpu time measurement +may be possible on some systems. The cpu time measurements are therefore +only reliable for the simpler benchmarks. + +The clock time measurement will of course include both the user and system +execution time, plus the time spent waiting for i/o. Any minor system daemon +processes executing while the benchmarks are being run may bias the clock +time measurement slightly, but since these are a constant part of the host +environment it is fair to include them in the timings. Major system daemons +which run infrequently (e.g., the print symbiont in VMS) should invalidate +the benchmark. + +A comparison of the cpu and clock times tells whether the benchmark was cpu +or i/o bound (assuming a single user system). Those benchmarks involving +compiled IRAF tasks do not include the process startup and pagein times +(these are measured by a different benchmark), hence the task should be run +once before running the benchmark to connect the subprocess and page in +the memory used by the task. A good procedure to follow is to run each +benchmark once to start the process, and then repeat the benchmark three times, +averaging the results. If inconsistent results are obtained further iterations +and/or monitoring of the host system are called for until a consistent result +is achieved. + +Many benchmarks depend upon disk performance as well as compute cycles. +For such a benchmark to be a meaningful measure of the i/o bandwidth of the +system it is essential that no other users (or batch jobs) be competing for +disk seeks on the disk used for the test file. There are subtle things to +watch out for in this regard, for example, if the machine is in a VMS cluster +or on a local area network, processes on other nodes may be accessing the +local disk, yet will not show up on a user login or process list on the local +node. It is always desirable to repeat each test several times or on several +different disk devices, to ensure that no outside requests were being serviced +while the benchmark was being run. If the system has disk monitoring utilities +use these to find an idle disk before running any benchmarks which do heavy i/o. + +Beware of disks which are nearly full; the maximum achievable i/o bandwidth +will fall off rapidly as a disk fills up, due to disk fragmentation (the file +must be stored in little pieces scattered all over the physical disk). +Similarly, many systems (VMS, AOS/VS) suffer from disk fragmentation problems +that gradually worsen as a files system ages, requiring that the disk +periodically be backed off onto tape and then restored. In some cases, +disk fragmentation can cause the maximum achievable i/o bandwidth to degrade +by an order of magnitude. + +.nh +The Benchmarks + + Instructions are given for running each benchmark, and the operations +performed by each benchmark are briefly described. The system characteristics +measured by the benchmark are briefly discussed. A short mnemonic name is +associated with each benchmark to identify it in the tables given in the +\fIresults\fR section. + +.nh 2 +Host Level Benchmarks + + The benchmarks discussed in this section are run at the host system level. +The examples are given for the UNIX cshell, under the assumption that a host +dependent example is better than none at all. These commands must be +translated by the user to run the benchmarks on a different system. + +.nh 3 +CL Startup/Shutdown [CLSS] + + Go to the CL login directory, mark the time (the method by which this is +done is system dependent), and startup the CL. Enter the "logout" command +while the CL is starting up so that the CL will not be idle (with the clock +running) while the command is being entered. Mark the final cpu and clock +time and compute the difference. + +.nf + % time cl + logout +.fi + +This is a complex benchmark but one which is of obvious importance to the +IRAF user. The benchmark is probably dominated by the cpu time required to +start up the CL, i.e., start up the CL process, initialize the i/o system, +initialize the environment, interpret the CL startup file, interpret the +user LOGIN.CL file, connect and disconnect the x_system.e subprocess, and so on. +Most of the remaining time is the overhead of the host operating system for +the process spawns, page faults, file accesses, and so on. + +.nh 3 +Mkpkg (verify) [MKPKGV] + + Go to the PKG directory and enter the (host system equivalent of the) +following command. The method by which the total cpu and clock times are +computed is system dependent. + +.nf + % cd $iraf/pkg + % time mkpkg -n +.fi + +This benchmark does a "no execute" make-package of the entire PKG suite of +applications and systems packages. This tests primarily the speed with which +the host system can read directories, resolve pathnames, and return directory +information for files. Since the PKG directory tree is continually growing, +this benchmark is only useful for comparing the same version of IRAF run on +different hosts, or the same version of IRAF on the same host at different +times. + +.nh 3 +Mkpkg (compile) [MKPKGC] + + Go to the directory "iraf$pkg/bench/xctest" and enter the (host system +equivalents of the) following commands. The method by which the total cpu +and clock times are computed is system dependent. Only the \fBmkpkg\fR +command should be timed. + +.nf + % cd $iraf/pkg/bench/xctest + % mkpkg clean # delete old library, etc., if present + % time mkpkg + % mkpkg clean # delete newly created binaries +.fi + +This tests the time required to compile and link a small IRAF package. +The timings reflect the time required to preprocess, compile, optimize, +and assemble each module and insert it into the package library, then link +the package executable. The host operating system overhead for the process +spawns, page faults, etc. is also a major factor. + +.nh 2 +IRAF Applications Benchmarks + + The benchmarks discussed in this section are run from within the IRAF +environment, using only standard IRAF applications tasks. The cpu and clock +execution times of any (compiled) IRAF task may be measured by prefixing +the task name with a $ when the command is entered, as shown in the examples. +The significance of the cpu time measurement is not precisely defined for +all systems. On a UNIX host, it is the "user" cpu time used by the task. +On a VMS host, there does not appear to be any distinction between the user +and system times (probably because the system services execute in the context +of the calling process), hence the cpu time given probably includes both. + +.nh 3 +Mkhelpdb [MKHDB] + + The \fBmkhelpdb\fR task is in the \fBsoftools\fR package. The function of +the task is to scan the tree of ".hd" help-directory files and compile the +binary help database. + +.nf + cl> softools + cl> $mkhelpdb +.fi + +This benchmark tests primarily the global optimization of the Fortran +compiler, since the code being executed is quite complex. It also tests the +speed with which text files can be opened and read. Since the size of the +help database varies with each version of IRAF, this benchmark is only useful +for comparing the same version of IRAF run on different hosts, or the same +version run on a single host at different times. + +.nh 3 +Sequential Image Operators [IMADDS,IMADDR,IMSTATR,IMSHIFTR] + + These benchmarks measure the time required by typical image operations. +All tests should be performed on 512 square test images created with the +\fBimdebug\fR package. The \fBimages\fR package will already have been +loaded by the \fBbench\fR package. Enter the following commands to create +the test images. + +.nf + cl> imdebug + cl> mktest pix.s s 2 "512 512" + cl> mktest pix.r r 2 "512 512" +.fi + +The following benchmarks should be run on these test images. Delete the +output images after each benchmark is run. Each benchmark should be run +several times, discarding the first timing and averaging the remaining +timings for the final result. +.ls +.ls [IMADDS] +cl> $imarith pix.s + 5 pix2.s +.le +.ls [IMADDR] +cl> $imarith pix.r + 5 pix2.r +.le +.ls [IMSTATR] +cl> $imstat pix.r +.le +.ls [IMSHIFTR] +cl> $imshift pix.r pix2.r .33 .44 interp=spline3 +.le +.le + +The IMADD benchmarks test the efficiency of the image i/o system, including +binary file i/o, and provide an indication of how long a simple disk to disk +image operation takes on the system in question. This benchmark should be +i/o bound on most systems. The IMSTATR and IMSHIFTR benchmarks are expected +to be cpu bound, and test primarily the quality of the code generated by the +host Fortran compiler. Note that the IMSHIFTR benchmark employs a true two +dimensional bicubic spline, hence the timings are a factor of 4 greater than +one would expect if a one dimensional interpolator were used to shift the two +dimensional image. + +.nh 3 +Image Load [IMLOAD,IMLOADF] + + To run the image load benchmarks, first load the \fBtv\fR package and +display something to get the x_display.e process into the process cache. +Run the following two benchmarks, displaying the test image PIX.S (this image +contains a test pattern of no interest). +.ls +.ls [IMLOAD] +cl> $display pix.s 1 +.le +.ls [IMLOADF] +cl> $display pix.s 1 zt=none +.le +.le + +The IMLOAD benchmark measures how long it takes for a normal image load on +the host system, including the automatic determination of the greyscale +mapping, and the time required to map and clip the image pixels into the +8 bits (or whatever) displayable by the image display. This benchmark +measures primarily the cpu speed and i/o bandwidth of the host system. +The IMLOADF benchmark eliminates the cpu intensive greyscale transformation, +yielding the minimum image display time for the host system. + +.nh 3 +Image Transpose [IMTRAN] + + To run this benchmark, transpose the image PIX.S, placing the output in a +new image. + + cl> $imtran pix.s pix2.s + +This benchmark tests the ability of a process to grab a large amount of +physical memory (large working set), and the speed with which the host system +can service random rather than sequential file access requests. + +.nh 2 +Specialized Benchmarks + + The next few benchmarks are implemented as tasks in the \fBbench\fR package, +located in the directory "pkg$bench". This package is not installed as a +predefined package as the standard IRAF packages are. Since this package is +used infrequently the binaries may have been deleted; if the file x_bench.e is +not present in the \fIbench\fR directory, rebuild it as follows: + +.nf + cl> cd pkg$bench + cl> mkpkg +.fi + +To load the package, enter the following commands. It is not necessary to +\fIcd\fR to the bench directory to load or run the package. + +.nf + cl> task $bench = "pkg$bench/bench.cl" + cl> bench +.fi + +This defines the following benchmark tasks. There are no manual pages for +these tasks; the only documentation is what you are reading. + +.ks +.nf + fortask - foreign task execution + getpar - get parameter; tests IPC overhead + plots - make line plots from an image + ptime - no-op task (prints the clock time) + rbin - read binary file; tests FIO bandwidth + rrbin - raw (unbuffered) binary file read + rtext - read text file; tests text file i/o speed + subproc - subprocess connect/disconnect + wbin - write binary file; tests FIO bandwidth + wipc - write to IPC; tests IPC bandwidth + wtext - write text file; tests text file i/o speed +.fi +.ke + +.nh 3 +Subprocess Connect/Disconnect [SUBPR] + + To run the SUBPR benchmark, enter the following command. +This will connect and disconnect the x_images.e subprocess 10 times. +Difference the starting and final times printed as the task output to get +the results of the benchmark. The cpu time measurement may be meaningless +(very small) on some systems. + + cl> subproc 10 + +This benchmark measures the time required to connect and disconnect an +IRAF subprocess. This includes not only the host time required to spawn +and later shutdown a process, but also the time required by the IRAF VOS +to set up the IPC channels, initialize the VOS i/o system, initialize the +environment in the subprocess, and so on. A portion of the subprocess must +be paged into memory to execute all this initialization code. The host system +overhead to spawn a subprocess and fault in a portion of its address space +is a major factor in this benchmark. + +.nh 3 +IPC Overhead [IPCO] + + The \fBgetpar\fR task is a compiled task in x_bench.e. The task will +fetch the value of a CL parameter 100 times. + + cl> $getpar 100 + +Since each parameter access consists of a request sent to the CL by the +subprocess, followed by a response from the CL process, with a negligible +amount of data being transferred in each call, this tests the IPC overhead. + +.nh 3 +IPC Bandwidth [IPCB] + + To run this benchmark enter the following command. The \fBwipc\fR task +is a compiled task in x_bench.e. + + cl> $wipc 1E6 > dev$null + +This writes approximately 1 Mb of binary data via IPC to the CL, which discards +the data (writes it to the null file via FIO). Since no actual disk file i/o is +involved, this tests the efficiency of the IRAF pseudofile i/o system and of the +host system IPC facility. + +.nh 3 +Foreign Task Execution [FORTSK] + + To run this benchmark enter the following command. The \fBfortask\fR +task is a CL script task in the \fBbench\fR package. + + cl> fortask 10 + +This benchmark executes the standard IRAF foreign task \fBrmbin\fR (one of the +bootstrap utilities) 10 times. The task is called with no arguments and does +nothing other than execute, print out its "usage" message, and shut down. +This tests the time required to execute a host system task from within the +IRAF environment. Only the clock time measurement is meaningful. + +.nh 3 +Binary File I/O [WBIN,RBIN,RRBIN] + + To run these benchmarks, load the \fBbench\fR package, and then enter the +following commands. The \fBwbin\fR, \fBrbin\fR and \fBrrbin\fR tasks are +compiled tasks in x_bench.e. A binary file named BINFILE is created in the +current directory by WBIN, and should be deleted after the benchmark has been +run. Each benchmark should be run at least twice before recording the time +and moving on to the next benchmark. Successive calls to WBIN will +automatically delete the file and write a new one. + +.nf + cl> $wbin binfile 5E6 + cl> $rbin binfile + cl> $rrbin binfile + cl> delete binfile # (not part of the benchmark) +.fi + +These benchmarks measure the time required to write and then read a binary disk +file approximately 5 Mb in size. This benchmark measures the binary file i/o +bandwidth of the FIO interface (for sequential i/o). In WBIN and RBIN the +common buffered READ and WRITE requests are used, hence some memory to memory +copying is included in the overhead measured by the benchmark. The RRBIN +benchmark uses ZARDBF to read the file in chunks of 32768 bytes, giving an +estimate of the maximum i/o bandwidth for the system. + +.nh 3 +Text File I/O [WTEXT,RTEXT] + + To run these benchmarks, load the \fBbench\fR package, and then enter the +following commands. The \fBwtext\fR and \fBrtext\fR tasks are compiled tasks +in x_bench.e. A text file named TEXTFILE is created in the current directory +by WTEXT, and should be deleted after the benchmarks have been run. +Successive calls to WTEXT will automatically delete the file and write a new +one. + +.nf + cl> $wtext textfile 1E6 + cl> $rtext textfile + cl> delete textfile # (not part of the benchmark) +.fi + +These benchmarks measure the time required to write and then read a text disk +file approximately one megabyte in size (15,625 64 character lines). +This benchmark measures the efficiency with which the system can sequentially +read and write text files. Since text file i/o requires the system to pack +and unpack records, text i/o tends to be cpu bound. + +.nh 3 +Network I/O [NWBIN,NRBIN,NWNULL,NWTEXT,NRTEXT] + + These benchmarks are equivalent to the binary and text file benchmarks +just discussed, except that the binary and text files are accessed on a +remote node via the IRAF network interface. The calling sequences are +identical except that an IRAF network filename is given instead of referencing +a file in the current directory. For example, the following commands would +be entered to run the network binary file benchmarks on node LYRA (the node +name and filename are site dependent). + +.nf + cl> $wbin lyra!/tmp3/binfile 5E6 [NWBIN] + cl> $rbin lyra!/tmp3/binfile [NRBIN] + cl> $wbin lyra!/dev/null 5E6 [NWNULL] + cl> delete lyra!/tmp3/binfile +.fi + +The text file benchmarks are equivalent with the obvious changes, i.e., +substitute "text" for "bin", "textfile" for "binfile", and omit the null +textfile benchmark. The type of network interface used (TCP/IP, DECNET, etc.), +and the characteristics of the remote node should be recorded. + +These benchmarks test the bandwidth of the IRAF network interfaces for binary +and text files, as well as the limiting speed of the network itself (NWNULL). +The binary file benchmarks should be i/o bound. NWBIN should outperform +NRBIN since a network write is a pipelined operation, whereas a network read +is (currently) a synchronous operation. Text file access may be either cpu +or i/o bound depending upon the relative speeds of the network and host cpus. +The IRAF network interface buffers textfile i/o to minimize the number of +network packets and maximize the i/o bandwidth. + +.nh 3 +Task, IMIO, GIO Overhead [PLOTS] + + The \fBplots\fR task is a CL script task which calls the \fBprow\fR task +repeatedly to plot the same line of an image. The graphics output is +discarded (directed to the null file) rather than plotted since otherwise +the results of the benchmark would be dominated by the plotting speed of the +graphics terminal. + + cl> plots pix.s 10 + +This is a complex benchmark. The benchmark measures the overhead of task +(not process) execution and the overhead of the IMIO and GIO subsystems, +as well as the speed with which IPC can be used to pass parameters to a task +and return the GIO graphics metacode to the CL. + +The \fBprow\fR task is all overhead and is not normally used to interactively +plot image lines (\fBimplot\fR is what is normally used), but it is a good +task to use for a benchmark since it exercises the subsystems most commonly +used in scientific tasks. The \fBprow\fR task has a couple dozen parameters +(mostly hidden), must open the image to read the image line to be plotted +on every call, and must open the GIO graphics device on every call as well. + +.nh 3 +System Loading [2USER,4USER] + + This benchmark attempts to measure the response of the system as the +load increases. This is done by running large \fBplots\fR jobs on several +terminals and then repeating the 10 plots \fBplots\fR benchmark. +For example, to run the 2USER benchmark, login on a second terminal and +enter the following command, and then repeat the PLOTS benchmark discussed +in the last section. Be sure to use a different login or login directory +for each "user", to avoid concurrency problems, e.g., when reading the +input image or updating parameter files. + + cl> plots pix.s 9999 + +Theoretically, the timings should be approximately .5 (2USER) and .25 (4USER) +as fast as when the PLOTS benchmark was run on a single user system, assuming +that cpu time is the limiting resource and that a single job is cpu bound. +In a case where there is more than one limiting resource, e.g., disk seeks as +well as cpu cycles, performance will fall off more rapidly. If, on the other +hand, a single user process does not keep the system busy, e.g., because +synchronous i/o is used, performance will fall off less rapidly. If the +system unexpectedly runs out of some critical system resource, e.g., physical +memory or some internal OS buffer space, performance may be much worse than +expected. + +If the multiuser performance is poorer than expected it may be possible to +improve the system performance significantly once the reason for the poor +performance is understood. If disk seeks are the problem it may be possible +to distribute the load more evenly over the available disks. If the +performance decays linearly as more users are added and then gets really bad, +it is probably because some critical system resource has run out. Use the +system monitoring tools provided with the host operating system to try to +identify the critical resource. It may be possible to modify the system +tuning parameters to fix the problem, once the critical resource has been +identified. + +.nh +Interpreting the Benchmark Results + + Many factors determine the timings obtained when the benchmarks are run +on a system. These factors include all of the following: + +.ls +.ls o +The hardware configuration, e.g., cpu used, clock speed, availability of +floating point hardware, type of floating point hardware, amount of memory, +number and type of disks, degree of fragmentation of the disks, bus bandwidth, +disk controller bandwidth, memory controller bandwidth for memory mapped DMA +transfers, and so on. +.le +.ls o +The host operating system, including the version number, tuning parameters, +user quotas, working set size, files system parameters, Fortran compiler +characteristics, level of optimization used to compile IRAF, and so on. +.le +.ls o +The version of IRAF being run. On a VMS system, are the images "installed" +to permit shared memory and reduce physical memory usage? Were the programs +compiled with the code optimizer, and if so, what compiler options were used? +Are shared libraries used if available on the host system? +.le +.ls o +Other activity in the system when the benchmarks were run. If there were no +other users on the machine at the time, how about batch jobs? If the machine +is on a cluster or network, were other nodes accessing the same disks? +How many other processes were running on the local node? Ideally, the +benchmarks should be run on an otherwise idle system, else the results may be +meaningless or next to impossible to interpret. Given some idea of how the +host system responds to loading, it is possible to estimate how a timing +will scale as the system is loaded, but the reverse operation is much more +difficult. +.le +.le + + +Because so many factors contribute to the results of a benchmark, it can be +difficult to draw firm conclusions from any benchmark, no matter how simple. +The hardware and software in modern computer systems is so complicated that +it is difficult even for an expert with a detailed knowledge and understanding +of the full system to explain in detail where the time is going, even when +running the simplest benchmark. On some recent message based multiprocessor +systems it is probably impossible to fully comprehend what is going on at any +given time, even if one fully understands how the system works, because of the +dynamic nature of such systems. + +Despite these difficulties, the benchmarks do provide a coarse measure of the +relative performance of different host systems, as well as some indication of +the efficiency of the IRAF VOS. The benchmarks are designed to measure the +performance of the \fIhost system\fR (both hardware and software) in a number +of important areas, all of which play a role in determining the suitability of +a system for scientific data processing. The benchmarks are \fInot\fR +designed to measure the efficiency of the IRAF software itself (except parts +of the VOS), e.g., there is no measure of the time taken by the CL to compile +and execute a script, no measure of the speed of the median algorithm or of +an image transpose, and so on. These timings are also important, of course, +but should be measured separately. Also, measurements of the efficiency of +individual applications programs are much less critical than the performance +criteria dealt with here, since it is relatively easy to optimize an +inefficient or poorly designed applications program, even a complex one like +the CL, but there is generally little one can do about the host system. + +The timings for the benchmarks for a number of host systems are given in the +appendices which follow. Sometimes there will be more than one set of +benchmarks for a given host system, e.g., because the system provided two or +more disks or floating point options with different levels of performance. +The notes at the end of each set of benchmarks are intended to document any +special features or problems of the host system which may have affected the +results. In general we did not bother to record things like system tuning +parameters, working set, page faults, etc., unless these were considered an +important factor in the benchmarks. In particular, few IRAF programs page +fault other than during process startup, hence this is rarely a significant +factor when running these benchmarks (except possibly in IMTRAN). + +Detailed results for each configuration of each host system are presented on +separate pages in the Appendices. A summary table showing the results of +selected benchmarks for all host systems at once is also provided. +The system characteristic or characteristics principally measured by each +benchmark is noted in the table below. This is only approximate, e.g., the +MIPS rating is a significant factor in all but the most i/o bound benchmarks. + +.ks +.nf + benchmark responsiveness mips flops i/o + + CLSS * + MKPKGV * + MKHDB * * + PLOTS * * + IMADDS * * + IMADDR * * + IMSTATR * + IMSHIFTR * + IMTRAN * + WBIN * + RBIN * +.fi +.ke + + +By \fIresponsiveness\fR we refer to the interactive response of the system +as perceived by the user. A system with a good interactive response will do +all the little things very fast, e.g., directory listings, image header +listings, plotting from an image, loading new packages, starting up a new +process, and so on. Machines which score high in this area will seem fast +to the user, whereas machines which score poorly will \fIseem\fR slow, +sometimes frustratingly slow, even though they may score high in the areas +of floating point performance, or i/o bandwidth. The interactive response +of a system obviously depends upon the MIPS rating of the system (see below), +but an often more significant factor is the design and computational complexity +of the host operating system itself, in particular the time taken by the host +operating system to execute system calls. Any system which spends a large +fraction of its time in kernel mode will probably have poor interactive +response. The response of the system to loading is also very important, +i.e., if the system has trouble with load balancing as the number of users +(or processes) increases, response will become increasingly erratic until the +interactive response is hopelessly poor. + +The MIPS column refers to the raw speed of the system when executing arbitrary +code containing a mixture of various types of instructions, but little floating +point, i/o, or system calls. A machine with a high MIPS rating will have a +fast cpu, e.g., a fast clock rate, fast memory access time, large cache memory, +and so on, as well as a good optimizing Fortran compiler. Assuming good +compilers, the MIPS rating is primarily a measure of the hardware speed of +the host machine, but all of the MIPS related benchmarks presented here also +make a significant number of system calls (MKHDB, for example, does a lot of +files accesses and text file i/o), hence it is not that simple. Perhaps a +completely cpu bound pure-MIPS benchmark should be added to our suite of +benchmarks (the MIPS rating of every machine is generally well known, however). + +The FLOPS column identifies those benchmarks which do a significant amount of +floating point computation. The IMSHIFTR and IMSTATR benchmarks in particular +are heavily into floating point. These benchmarks measure the single +precision floating point speed of the host system hardware, as well as the +effectiveness of do-loop optimization by the host Fortran compiler. +The degree of optimization provided by the Fortran compiler can affect the +timing of these benchmarks by up to a factor of two. Note that the sample is +very small, and if a compiler fails to optimize the inner loop of one of these +benchmark programs, the situation may be reversed when running some other +benchmark. Any reasonable Fortran compiler should be able to optimize the +inner loop of the IMADDR benchmark, so the CPU timing for this benchmark is +a good measure of the hardware floating point speed, if one allows for do-loop +overhead, memory i/o, and the system calls necessary to access the image on +disk. + +The I/O column identifies those benchmarks which are i/o bound and which +therefore provide some indication of the i/o bandwidth of the host system. +The i/o bandwidth actually achieved in these benchmarks depends upon +many factors, the most important of which are the host operating system +software (files system data structures and i/o software, disk drivers, etc.) +and the host system hardware, i.e., disk type, disk controller type, bus +bandwidth, and DMA memory controller bandwidth. Note that asynchronous i/o +is not currently used in these benchmarks, hence higher transfer rates are +probably possible in special cases (on a busy system all i/o is asynchronous +at the host system level anyway). Large transfers are used to minimize disk +seeks and synchronization delays, hence the benchmarks should provide a good +measure of the realistically achievable host i/o bandwidth. + +.bp + . +.sp 20 +.ce +APPENDIX 1. IRAF VERSION 2.5 BENCHMARKS +.ce +April-June 1987 + +.bp +.sh +UNIX/IRAF V2.5 4.3BSD UNIX, 8Mb memory, VAX 11/750+FPA RA81 (lyra) +.br +CPU times are given in seconds, CLK times in minutes and seconds. +.br +Wednesday, 1 April, 1987, Suzanne H. Jacoby, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes \fR + (user+sys) (m:ss) + +CLSS 7.4+2.6 0:17 CPU = user + system +MKPKGV 13.4+9.9 0:39 CPU = user + system +MKPKGC 135.1+40. 3:46 CPU = user + system +MKHDB 22.79 0:40 [1] +IMADDS 3.31 0:10 512X512X16 +IMADDR 4.28 0:17 512X512X32 +IMSTATR 10.98 0:15 512X512X32 +IMSHIFTR 114.41 2:13 512X512X32 +IMLOAD 7.62 0:15 512X512X16 +IMLOADF 2.63 0:08 512X512X16 +IMTRAN 10.19 0:17 512X512X16 +SUBPR n/a 0:20 10 conn/discon 2.0 sec/proc +IPCO 0.92 0:07 100 getpars +IPCB 2.16 0:15 1E6 bytes 66.7 Kb/sec +FORTSK n/a 0:06 10 commands 0.6 sec/cmd +WBIN 4.32 0:24 5E6 bytes 208.3 Kb/sec +RBIN 4.08 0:24 5E6 bytes 208.3 Kb/sec +RRBIN 0.12 0:22 5E6 bytes 227.3 Kb/sec +WTEXT 37.30 0:42 1E6 bytes 23.8 Kb/sec +RTEXT 26.49 0:32 1E6 bytes 31.3 Kb/sec +NWBIN 4.64 1:43 5E6 bytes 48.5 Kb/sec [2] +NRBIN 6.49 1:34 5E6 bytes 53.2 Kb/sec [2] +NWNULL 4.91 1:21 5E6 bytes 61.7 Kb/sec [2] +NWTEXT 44.03 1:02 1E6 bytes 16.1 Kb/sec [2] +NRTEXT 31.38 2:04 1E6 bytes 8.1 Kb/sec [2] +PLOTS n/a 0:29 10 plots 2.9 sec/PROW +2USER n/a 0:44 10 plots 4.4 sec/PROW +4USER n/a 1:19 10 plots 7.9 sec/PROW +.fi + + +Notes: +.ls [1] +All cpu timings from MKHDB on do not include the "system" time. +.le +.ls [2] +The remote node used for the network tests was aquila, a VAX 11/750 running +4.3 BSD UNIX. The network protocol used was TCP/IP. +.le + +.bp +.sh +UNIX/IRAF V2.5 SUN UNIX 3.3, SUN 3/160C, (tucana) +.br +16 MHz 68020, 68881 fpu, 8Mb, 2-380Mb Fujitsu Eagle disks +.br +Friday, June 12, 1987, Suzanne H. Jacoby, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes \fR + (user+sys) (m:ss) + +CLSS 2.0+0.8 0:03 CPU = user + system +MKPKGV 3.2+4.5 0:17 CPU = user + system +MKPKGC 59.1+26.2 2:13 CPU = user + system +MKHDB 5.26 0:10 [1] +IMADDS 0.62 0:03 512X512X16 +IMADDR 3.43 0:09 512X512X32 +IMSTATR 8.38 0:11 512X512X32 +IMSHIFTR 83.44 1:33 512X512X32 +IMLOAD 6.78 0:11 512X512X16 +IMLOADF 1.21 0:03 512X512X16 +IMTRAN 1.47 0:05 512X512X16 +SUBPR n/a 0:07 10 conn/discon 0.7 sec/proc +IPCO 0.16 0:02 100 getpars +IPCB 0.70 0:05 1E6 bytes 200.0 Kb/sec +FORTSK n/a 0:02 10 commands 0.2 sec/cmd +WBIN 2.88 0:08 5E6 bytes 625.0 Kb/sec +RBIN 2.58 0:11 5E6 bytes 454.5 Kb/sec +RRBIN 0.01 0:10 5E6 bytes 500.0 Kb/sec +WTEXT 9.20 0:10 1E6 bytes 100.0 Kb/sec +RTEXT 6.75 0:07 1E6 bytes 142.8 Kb/sec +NWBIN 2.65 1:04 5E6 bytes 78.1 Kb/sec [2] +NRBIN 3.42 1:16 5E6 bytes 65.8 Kb/sec [2] +NWNULL 2.64 1:01 5E6 bytes 82.0 Kb/sec [2] +NWTEXT 11.92 0:39 1E6 bytes 25.6 Kb/sec [2] +NRTEXT 7.41 1:24 1E6 bytes 11.9 Kb/sec [2] +PLOTS n/a 0:09 10 plots 0.9 sec/PROW +2USER n/a 0:16 10 plots 1.6 sec/PROW +4USER n/a 0:35 10 plots 3.5 sec/PROW +.fi + + +Notes: +.ls [1] +All timings from MKHDB on do not include the "system" time. +.le +.ls [2] +The remote node used for the network tests was aquila, a VAX 11/750 +running 4.3BSD UNIX. The network protocol used was TCP/IP. +.le + +.bp +.sh +UNIX/IRAF V2.5 SUN UNIX 3.3, SUN 3/160C + FPA (KPNO 4 meter system) +.br +16 MHz 68020, Sun-3 FPA, 8Mb, 2-380Mb Fujitsu Eagle disks +.br +Friday, June 12, 1987, Suzanne H. Jacoby, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes \fR + (user+sys) (m:ss) + +CLSS 1.9+0.7 0:04 CPU = user + system +MKPKGV 3.1+3.9 0:19 CPU = user + system +MKPKGC 66.2+20.3 2:06 CPU = user + system +MKHDB 5.30 0:11 [1] +IMADDS 0.63 0:03 512X512X16 +IMADDR 0.86 0:06 512X512X32 +IMSTATR 5.08 0:08 512X512X32 +IMSHIFTR 31.06 0:36 512X512X32 +IMLOAD 2.76 0:06 512X512X16 +IMLOADF 1.22 0:03 512X512X16 +IMTRAN 1.46 0:04 512X512X16 +SUBPR n/a 0:06 10 conn/discon 0.6 sec/proc +IPCO 0.16 0:01 100 getpars +IPCB 0.60 0:05 1E6 bytes 200.0 Kb/sec +FORTSK n/a 0:02 10 commands 0.2 sec/cmd +WBIN 2.90 0:07 5E6 bytes 714.3 Kb/sec +RBIN 2.54 0:11 5E6 bytes 454.5 Kb/sec +RRBIN 0.03 0:10 5E6 bytes 500.0 Kb/sec +WTEXT 9.20 0:11 1E6 bytes 90.9 Kb/sec +RTEXT 6.70 0:08 1E6 bytes 125.0 Kb/sec +NWBIN n/a +NRBIN n/a [3] +NWNULL n/a +NWTEXT n/a +NRTEXT n/a +PLOTS n/a 0:06 10 plots 0.6 sec/PROW +2USER n/a 0:10 10 plots 1.0 sec/PROW +4USER n/a 0:26 10 plots 2.6 sec/PROW +.fi + + +Notes: +.ls [1] +All timings from MKHDB on do not include the "system" time. +.le + +.bp +.sh +UNIX/IRAF V2.5, SUN UNIX 3.2, SUN 3/160 (taurus) +.br +16 MHz 68020, Sun-3 FPA, 16 Mb, SUN SMD disk 280 Mb +.br +7 April 1987, Skip Schaller, Steward Observatory, University of Arizona + +.nf +\fBBenchmark CPU CLK Size Notes\fR + (user+sys) (m:ss) + +CLSS 01.2+01.1 0:03 +MKPKGV 03.2+10.1 0:18 +MKPKGC 65.4+25.7 2:03 +MKHDB 5.4 0:18 +IMADDS 0.6 0:04 512x512x16 +IMADDR 0.9 0:07 512x512x32 +IMSTATR 11.4 0:13 512x512x32 +IMSHIFTR 30.1 0:34 512x512x32 +IMLOAD (not available) +IMLOADF (not available) +IMTRAN 1.4 0:04 512x512x16 +SUBPR - 0:07 10 conn/discon 0.7 sec/proc +IPCO 0.1 0:02 100 getpars +IPCB 0.8 0:05 1E6 bytes 200.0 Kb/sec +FORTSK - 0:03 10 commands 0.3 sec/cmd +WBIN 2.7 0:14 5E6 bytes 357.1 Kb/sec +RBIN 2.5 0:09 5E6 bytes 555.6 Kb/sec +RRBIN 0.1 0:06 5E6 bytes 833.3 Kb/sec +WTEXT 9.0 0:10 1E6 bytes 100.0 Kb/sec +RTEXT 6.4 0:07 1E6 bytes 142.9 Kb/sec +NWBIN 2.8 1:08 5E6 bytes 73.5 Kb/sec +NRBIN 3.1 1:25 5E6 bytes 58.8 Kb/sec +NWNULL 2.7 0:55 5E6 bytes 90.9 Kb/sec +NWTEXT 12.3 0:44 1E6 bytes 22.7 Kb/sec +NRTEXT 7.7 1:45 1E6 bytes 9.5 Kb/sec +PLOTS - 0:07 10 plots 0.7 sec/PROW +2USER - 0:13 +4USER - 0:35 +.fi + + +Notes: +.ls [1] +The remote node used for the network tests was carina, a VAX 11/750 +running 4.3 BSD UNIX. The network protocol used was TCP/IP. +.le + +.bp +.sh +Integrated Solutions (ISI), Lick Observatory +.br +16-Mhz 68020, 16-Mhz 68881 fpu, 8Mb Memory +.br +IRAF compiled with Greenhills compilers without -O optimization +.br +Thursday, 14 May, 1987, Richard Stover, Lick Observatory + +.nf +\fBBenchmark CPU CLK Size Notes\fR + (user+sys) (m:ss) + +CLSS 1.6+0.7 0:03 +MKPKGV 3.1+4.6 0:25 +MKPKGC 40.4+11.6 1:24 +MKHDB 6.00 0:17 +IMADDS 0.89 0:05 512X512X16 +IMADDR 3.82 0:10 512X512X32 +IMSTATR 7.77 0:10 512X512X32 +IMSHIFTR 81.60 1:29 512X512X32 +IMLOAD n/a +IMLOADF n/a +IMTRAN 1.62 0:06 512X512X16 +SUBPR n/a 0:05 10 donn/discon 0.5 sec/proc +IPCO 0.27 0:02 100 getpars +IPCB 1.50 0:08 1E6 bytes 125.0 Kb/sec +FORTSK n/a 0:13 10 commands 1.3 sec/cmd +WBIN 4.82 0:17 5E6 bytes 294.1 Kb/sec +RBIN 4.63 0:18 5E6 bytes 277.8 Kb/sec +RRBIN 0.03 0:13 5E6 bytes 384.6 Kb/sec +WTEXT 17.10 0:19 1E6 bytes 45.5 Kb/sec +RTEXT 7.40 0:08 1E6 bytes 111.1 Kb/sec +NWBIN n/a +NRBIN n/a +NWNULL n/a +NWTEXT n/a +NRTEXT n/a +PLOTS n/a 0:10 10 plots 1.0 sec/PROW +2USER n/a +4USER n/a +.fi + + +Notes: +.ls [1] +An initial attempt to bring IRAF up on the ISI using the ISI C and Fortran +compilers failed due to there being too many bugs in these compilers, so +the system was brought up using the Greenhills compilers. +.le + +.bp +.sh +ULTRIX/IRAF V2.5, ULTRIX 1.2, VAXStation II/GPX (gll1) +.br +5Mb memory, 150 Mb RD54 disk +.br +Thursday, 21 May, 1987, Suzanne H. Jacoby, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes \fR + (user+sys) (m:ss) + +CLSS 4.2+1.8 0:09 CPU = user + system +MKPKGV 9.8+6.1 0:37 CPU = user + system +MKPKGC 96.8+24.4 3:15 CPU = user + system +MKHDB 15.50 0:38 [1] +IMADDS 2.06 0:09 512X512X16 +IMADDR 2.98 0:17 512X512X32 +IMSTATR 10.98 0:16 512X512X32 +IMSHIFTR 95.61 1:49 512X512X32 +IMLOAD 6.90 0:17 512X512X16 [2] +IMLOADF 2.58 0:10 512X512X16 [2] +IMTRAN 4.93 0:16 512X512X16 +SUBPR n/a 0:19 10 conn/discon 1.9 sec/proc +IPCO 0.47 0:03 100 getpars +IPCB 1.21 0:07 1E6 bytes 142.9 Kb/sec +FORTSK n/a 0:08 10 commands 0.8 sec/cmd +WBIN 1.97 0:29 5E6 bytes 172.4 Kb/sec +RBIN 1.73 0:24 5E6 bytes 208.3 Kb/sec +RRBIN 0.08 0:24 5E6 bytes 208.3 Kb/sec +WTEXT 25.43 0:27 1E6 bytes 37.0 Kb/sec +RTEXT 16.65 0:18 1E6 bytes 55.5 Kb/sec +NWBIN 2.24 1:26 5E6 bytes 58.1 Kb/sec [3] +NRBIN 2.66 1:43 5E6 bytes 48.5 Kb/sec [3] +NWNULL 2.22 2:21 5E6 bytes 35.5 Kb/sec [3] +NWTEXT 27.16 2:43 1E6 bytes 6.1 Kb/sec [3] +NRTEXT 17.44 2:17 1E6 bytes 7.3 Kb/sec [3] +PLOTS n/a 0:20 10 plots 2.0 sec/PROW +2USER n/a 0:30 10 plots 3.0 sec/PROW +4USER n/a 0:51 10 plots 5.1 sec/PROW +.fi + + +Notes: +.ls [1] +All cpu timings from MKHDB on do not include the "system" time. +.le +.ls [2] +Since there is no image display on this node, the image display benchmarks +were run using the IIS display on node lyra via the network interface. +.le +.ls [3] +The remote node used for the network tests was lyra, a VAX 11/750 running +4.3 BSD UNIX. The network protocol used was TCP/IP. +.le +.ls [4] +Much of the hardware and software for this system was provided courtesy of +DEC so that we may better support IRAF on the microvax. +.le + +.bp +.sh +VMS/IRAF V2.5, VMS V4.5, 28Mb, VAX 8600 RA81/Clustered (draco) +.br +Friday, 15 May, 1987, Suzanne H. Jacoby, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes \fR + (user+sys) (m:ss) + +CLSS 2.87 0:08 +MKPKGV 33.57 1:05 +MKPKGC 3.26 1:16 +MKHDB 8.59 0:17 +IMADDS 1.56 0:05 512X512X16 +IMADDR 1.28 0:07 512X512X32 +IMSTATR 2.09 0:04 512X512X32 +IMSHIFTR 13.54 0:32 512X512X32 +IMLOAD 2.90 0:10 512X512X16 [1] +IMLOADF 1.04 0:08 512X512X16 [1] +IMTRAN 2.58 0:06 512X512X16 +SUBPR n/a 0:27 10 conn/discon 2.7 sec/proc +IPCO 0.00 0:02 100 getpars +IPCB 0.04 0:06 1E6 bytes 166.7 Kb/sec +FORTSK n/a 0:13 10 commands 1.3 sec/cmd +WBIN 1.61 0:17 5E6 bytes 294.1 Kb/sec +RBIN 1.07 0:08 5E6 bytes 625.0 Kb/sec +RRBIN 0.34 0:08 5E6 bytes 625.0 Kb/sec +WTEXT 10.62 0:17 1E6 bytes 58.8 Kb/sec +RTEXT 4.64 0:06 1E6 bytes 166.7 Kb/sec +NWBIN 2.56 2:00 5E6 bytes 41.7 Kb/sec [2] +NRBIN 5.67 1:57 5E6 bytes 42.7 Kb/sec [2] +NWNULL 2.70 1:48 5E6 bytes 46.3 Kb/sec [2] +NWTEXT 12.06 0:47 1E6 bytes 21.3 Kb/sec [2] +NRTEXT 10.10 1:41 1E6 bytes 9.9 Kb/sec [2] +PLOTS n/a 0:09 10 plots 0.9 sec/PROW +2USER n/a 0:10 10 plots 1.0 sec/PROW +4USER n/a 0:18 10 plots 1.8 sec/PROW +.fi + + +Notes: +.ls [1] +The image display was accessed via the network (IRAF TCP/IP network interface, +Wollongong TCP/IP package for VMS), with the IIS image display residing on +node lyra and accessed via a UNIX/IRAF kernel server. The binary and text +file network tests also used lyra as the remote node. +.le +.ls [2] +The remote node for network benchmarks was aquila, a VAX 11/750 running +4.3BSD UNIX. Connection made via TCP/IP. +.le +.ls [3] +The system was linked using shared libraries and the IRAF executables for +the cl and system tasks, as well as the shared library, were "installed" +using the VMS INSTALL utility. +.le +.ls [4] +The high value of the IPC bandwidth for VMS is due to the use of shared +memory. Mailboxes were considerably slower and are no longer used. +.le +.ls [5] +The foreign task interface uses mailboxes to talk to a DCL run as a +subprocess and should be considerably faster than it is. It is slow at +present due to the need to call SET MESSAGE before and after the user +command to disable pointless DCL error messages having to do with +logical names. +.le + +.bp +.sh +VMS/IRAF V2.5, VAX 11/780, VMS V4.5, 16Mb memory, RA81 disks (wfpct1) +.br +Tuesday, 19 May, 1987, Suzanne H. Jacoby, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes\fR + (user+sys) (m:ss) + +CLSS 7.94 0:15 +MKPKGV 102.49 2:09 +MKPKGC 9.50 2:22 +MKHDB 26.10 0:31 +IMADDS 3.57 0:10 512X512X16 +IMADDR 4.22 0:17 512X512X32 +IMSTATR 6.78 0:10 512X512X32 +IMSHIFTR 45.11 0:57 512X512X32 +IMLOAD n/a +IMLOADF n/a +IMTRAN 7.83 0:14 512X512X16 +SUBPR n/a 0:53 10 donn/discon 5.3 sec/proc +IPCO 0.02 0:03 100 getpars +IPCB 0.17 0:10 1E6 bytes 100.0 Kb/sec +FORTSK n/a 0:20 10 commands 2.0 sec/cmd +WBIN 4.52 0:30 5E6 bytes 166.7 Kb/sec +RBIN 3.90 0:19 5E6 bytes 263.2 Kb/sec +RRBIN 1.23 0:17 5E6 bytes 294.1 Kb/sec +WTEXT 37.99 0:50 1E6 bytes 20.0 Kb/sec +RTEXT 18.52 0:19 1E6 bytes 52.6 Kb/sec +NWBIN n/a +NRBIN n/a +NWNULL n/a +NWTEXT n/a +NRTEXT n/a +PLOTS n/a 0:19 10 plots 1.9 sec/PROW +2USER n/a 0:31 10 plots 3.1 sec/PROW +4USER n/a 1:04 10 plots 6.4 sec/PROW +.fi + + +Notes: +.ls [1] +The Unibus interface used for the RA81 disks for these benchmarks is +notoriously slow, hence the i/o bandwidth of the system as tested was +probably significantly worse than many sites would experience (using +disks on the faster Massbus interface). +.le + +.bp +.sh +VMS/IRAF V2.5, VAX 11/780, VMS V4.5 (wfpct1) +.br +16Mb memory, IRAF installed on RA81 disks, data on RM03/Massbus [1]. +.br +Tuesday, 9 June, 1987, Suzanne H. Jacoby, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes\fR + (user+sys) (m:ss) + +CLSS n/a +MKPKGV n/a +MKPKGC n/a +MKHDB n/a +IMADDS 3.38 0:08 512X512X16 +IMADDR 4.00 0:11 512X512X32 +IMSTATR 6.88 0:08 512X512X32 +IMSHIFTR 45.47 0:53 512X512X32 +IMLOAD n/a +IMLOADF n/a +IMTRAN 7.71 0:12 512X512X16 +SUBPR n/a +IPCO n/a +IPCB n/a +FORTSK n/a +WBIN 4.22 0:22 5E6 bytes 227.3 Kb/sec +RBIN 3.81 0:12 5E6 bytes 416.7 Kb/sec +RRBIN 0.98 0:09 5E6 bytes 555.6 Kb/sec +WTEXT 37.20 0:47 1E6 bytes 21.3 Kb/sec +RTEXT 17.95 0:18 1E6 bytes 55.6 Kb/sec +NWBIN n/a +NRBIN n/a +NWNULL n/a +NWTEXT n/a +NRTEXT n/a +PLOTS n/a 0:16 10 plots 1.6 sec/PROW +2USER +4USER +.fi + +Notes: +.ls [1] +The data files were stored on an RM03 with 23 free Mb and a Massbus interface +for these benchmarks. Only those benchmarks which access the RM03 are given. +.le + +.bp +.sh +VMS/IRAF V2.5, MicroVMS 4.5, VAXStation II/GPX (gll1) +.br +5Mb memory, 70Mb RD53 plus 300 Mb Maxstor with Emulex controller. +.br +Wednesday, 13 May, 1987, Suzanne H. Jacoby, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes\fR + (user+sys) (m:ss) + +CLSS 9.66 0:17 +MKPKGV 109.26 2:16 +MKPKGC 9.25 2:53 +MKHDB 27.58 0:39 +IMADDS 3.51 0:07 512X512X16 +IMADDR 4.31 0:10 512X512X32 +IMSTATR 9.31 0:11 512X512X32 +IMSHIFTR 74.54 1:21 512X512X32 +IMLOAD n/a +IMLOADF n/a +IMTRAN 10.81 0:27 512X512X16 +SUBPR n/a 0:53 10 conn/discon 5.3 sec/proc +IPCO 0.03 0:03 100 getpars +IPCB 0.13 0:07 1E6 bytes 142.8 Kb/sec +FORTSK n/a 0:29 10 commands 2.9 sec/cmd +WBIN 3.29 0:16 5E6 bytes 312.5 Kb/sec +RBIN 2.38 0:10 5E6 bytes 500.0 Kb/sec +RRBIN 0.98 0:09 5E6 bytes 555.5 Kb/sec +WTEXT 41.00 0:53 1E6 bytes 18.9 Kb/sec +RTEXT 28.74 0:29 1E6 bytes 34.5 Kb/sec +NWBIN 8.28 0:46 5E6 bytes 108.7 Kb/sec [1] +NRBIN 5.66 0:50 5E6 bytes 100.0 Kb/sec [1] +NWNULL 8.39 0:42 5E6 bytes 119.0 Kb/sec [1] +NWTEXT 30.21 0:33 1E6 bytes 30.3 Kb/sec [1] +NRTEXT 20.05 0:38 1E6 bytes 26.3 Kb/sec [1] +PLOTS 0:16 10 plots 1.6 sec/plot +2USER 0:26 10 plots 2.6 sec/plot +4USER +.fi + +Notes: +.ls [1] +The remote node for the network tests was draco, a VAX 8600 running +V4.5 VMS. The network protocol used was DECNET. +.le +.ls [2] +Much of the hardware and software for this system was provided courtesy of +DEC so that we may better support IRAF on the microvax. +.le + +.bp +.sh +VMS/IRAF V2.5, MicroVMS 4.5, VAXStation II/GPX (gll1) +.br +5 Mb memory, IRAF on 300 Mb Maxstor/Emulex, data on 70 Mb RD53 [1]. +.br +Sunday, 31 May, 1987, Suzanne H. Jacoby, NOAO/Tucson. + +.nf +\fBBenchmark CPU CLK Size Notes\fR + (user+sys) (m:ss) + +CLSS n/a n/a +MKPKGV n/a n/a +MKPKGC n/a n/a +MKHDB n/a n/a +IMADDS 3.44 0:07 512X512X16 +IMADDR 4.31 0:15 512X512X32 +IMSTATR 9.32 0:12 512X512X32 +IMSHIFTR 74.72 1:26 512X512X32 +IMLOAD n/a +IMLOADF n/a +IMTRAN 10.83 0:35 512X512X16 +SUBPR n/a +IPCO n/a +IPCB n/a +FORTSK n/a +WBIN 3.33 0:26 5E6 bytes 192.3 Kb/sec +RBIN 2.30 0:17 5E6 bytes 294.1 Kb/sec +RRBIN 0.97 0:11 5E6 bytes 294.1 Kb/sec +WTEXT 40.84 0:54 1E6 bytes 18.2 Kb/sec +RTEXT 27.99 0:28 1E6 bytes 35.7 Kb/sec +NWBIN n/a +NRBIN n/a +NWNULL n/a +NWTEXT n/a +NRTEXT n/a +PLOTS 0:17 10 plots 1.7 sec/plot +2USER n/a +4USER n/a +.fi + + +Notes: +.ls [1] +IRAF installed on a 300 Mb Maxstor with Emulax controller; data files on a +70Mb RD53. Only those benchmarks which access the RD53 disk are included +below. +.le + +.bp +.sh +VMS/IRAF V2.5, VMS V4.5, VAX 11/750+FPA RA81/Clustered, 7.25 Mb (vela) +.br +Friday, 15 May 1987, Suzanne H. Jacoby, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes \fR + (user+sys) (m:ss) + +CLSS 14.11 0:27 +MKPKGV 189.67 4:17 +MKPKGC 18.08 3:44 +MKHDB 46.54 1:11 +IMADDS 5.90 0:11 512X512X16 +IMADDR 6.48 0:14 512X512X32 +IMSTATR 10.65 0:14 512X512X32 +IMSHIFTR 69.62 1:33 512X512X32 +IMLOAD 15.83 0:23 512X512X16 +IMLOADF 6.08 0:13 512X512X16 +IMTRAN 14.85 0:20 512X512X16 +SUBPR n/a 1:54 10 conn/discon 11.4 sec/proc +IPCO 1.16 0:06 100 getpars +IPCB 2.92 0:09 1E6 bytes 111.1 Kb/sec +FORTSK n/a 0:33 10 commands 3.3 sec/cmd +WBIN 6.96 0:21 5E6 bytes 238.1 Kb/sec +RBIN 5.37 0:13 5E6 bytes 384.6 Kb/sec +RRBIN 1.86 0:10 5E6 bytes 500.0 Kb/sec +WTEXT 66.12 1:24 1E6 bytes 11.9 Kb/sec +RTEXT 32.06 0:36 1E6 bytes 27.7 Kb/sec +NWBIN 13.53 1:49 5E6 bytes 45.9 Kb/sec [1] +NRBIN 19.52 2:06 5E6 bytes 39.7 Kb/sec [1] +NWNULL 13.40 1:44 5E6 bytes 48.1 Kb/sec [1] +NWTEXT 82.35 1:42 1E6 bytes 9.8 Kb/sec [1] +NRTEXT 63.00 2:39 1E6 bytes 6.3 Kb/sec [1] +PLOTS n/a 0:25 10 plots 2.5 sec/PROW +2USER n/a 0:53 10 plots 5.3 sec/PROW +4USER n/a 1:59 10 plots 11.9 sec/PROW +.fi + + +Notes: +.ls [1] +The remote node for network benchmarks was aquila, a VAX 11/750 running +4.3BSD UNIX. Connection made via TCP/IP. +.le +.ls [2] +The interactive response of this system seemed to decrease markedly when it +was converted to 4.X VMS and is currently pretty marginal, even on a single +user 11/750. In interactive applications which make frequent system calls the +system tends to spend much of the available cpu time in kernel mode even if +there are only a few active users. +.le +.ls [2] +Compare the 2USER and 4USER timings with those for the UNIX 11/750. This +benchmark is characteristic of the two systems. No page faulting was evident +on the VMS 11/750 during the multiuser benchmarks. It took much longer to +run the 4USER benchmark on the VMS 750, as the set up time was much longer +once one or two other PLOTS jobs were running. The UNIX machine, on the other +hand, seemed almost as fast (or as slow) as usual, even with the PLOTS jobs +running on the other terminals. +.le +.ls [4] +The high value of the IPC bandwidth for VMS is due to the use of shared +memory. Mailboxes were considerably slower and are no longer used. +.le +.ls [5] +The foreign task interface uses mailboxes to talk to a DCL run as a subprocess +and should be considerably faster than it is. It is slow at present due to +the need to call SET MESSAGE before and after the user command to disable +pointless DCL error messages having to do with logical names. +.le + +.bp +.sh +AOSVS/IRAF V2.5, AOSVS 7.54, Data General MV 10000 (solpl) +.br +24Mb, 2-600 Mb ARGUS disks and 2-600 Mb KISMET disks +.br +17 April 1987, Skip Schaller, Steward Observatory, University of Arizona + +.nf +\fBBenchmark CPU CLK Size Notes\fR + (sec) (m:ss) +CLSS 2.1 0:14 [1] +MKPKGV 9.6 0:29 +MKPKGC n/a 3:43 +MKHDB 6.4 0:25 +IMADDS 1.5 0:06 512x512x16 +IMADDR 1.6 0:08 512x512x32 +IMSTATR 4.8 0:07 512x512x32 +IMSHIFTR 39.3 0:47 512x512x32 +IMLOAD 3.1 0:08 512x512x16 [2] +IMLOADF 0.8 0:06 512x512x16 [2] +IMTRAN 2.9 0:06 512x512x16 +SUBPR n/a 0:36 10 conn/discon 3.6 sec/proc +IPCO 0.4 0:03 100 getpars +IPCB 0.9 0:07 1E6 bytes 142.9 Kb/sec +FORTSK n/a 0:17 10 commands 1.7 sec/cmd +WBIN 1.7 0:56 5E6 bytes 89.3 Kb/sec [3] +RBIN 1.7 0:25 5E6 bytes 200.0 Kb/sec [3] +RRBIN 0.5 0:27 5E6 bytes 185.2 Kb/sec [3] +WTEXT 12.7 0:25 1E6 bytes 40.0 Kb/sec [3] +RTEXT 8.4 0:13 1E6 bytes 76.9 Kb/sec [3] +CSTC 0.0 0:00 5E6 bytes [4] +WSTC 1.9 0:11 5E6 bytes 454.5 Kb/sec +RSTC 1.5 0:11 5E6 bytes 454.5 Kb/sec +RRSTC 0.1 0:10 5E6 bytes 500.0 Kb/sec +NWBIN 2.0 1:17 5E6 bytes 64.9 Kb/sec [5] +NRBIN 2.1 2:34 5E6 bytes 32.5 Kb/sec +NWNULL 2.0 1:15 5E6 bytes 66.7 Kb/sec +NWTEXT 15.1 0:41 1E6 bytes 24.4 Kb/sec +NRTEXT 8.7 0:55 1E6 bytes 18.2 Kb/sec +PLOTS n/a 0:09 10 plots 0.9 sec/PROW +2USER n/a 0:12 +4USER n/a 0:20 +.fi + + +Notes: +.ls [1] +The CLSS given is for a single user on the system. With one user already +logged into IRAF, the CLSS was 0:10. +.le +.ls [2] +These benchmarks were measured on the CTI system, an almost identically +configured MV/10000, with an IIS Model 75. +.le +.ls [3] +I/O throughput depends heavily on the element size of an AOSVS file. For +small element sizes, the throughput is roughly proportional to the element +size. I/O throughput in general could improve when IRAF file i/o starts +using double buffering and starts taking advantage of the asynchronous +definition of the kernel i/o drivers. +.le +.ls [4] +These static file benchmarks are not yet official IRAF benchmarks, but are +analogous to the binary file benchmarks. Since they use the supposedly +more efficient static file driver, they should give a better representation +of the true I/O throughput of the system. Since these are the drivers used +for image I/O, they represent the I/O throughput for the bulk image files. +.le +.ls [5] +The remote node used for the network tests was taurus, a SUN 3-160 +running SUN/UNIX 3.2. The network protocol used was TCP/IP. +.le + +.bp +.sh +AOSVS/IRAF V2.5, Data General MV 8000 (CTIO La Serena system) +.br +5Mb memory (?), 2 large DG disks plus 2 small Winchesters [1] +.br +17 April 1987, Doug Tody, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes\fR + (sec) (m:ss) +CLSS n/a 0:28 [2] +MKPKGV n/a 2:17 +MKPKGC n/a 6:38 +MKHDB 13.1 0:57 +IMADDS 2.9 0:12 512x512x16 +IMADDR 3.1 0:17 512x512x32 +IMSTATR 9.9 0:13 512x512x32 +IMSHIFTR 77.7 1:31 512x512x32 +IMLOAD n/a +IMLOADF n/a +IMTRAN 5.69 0:12 512x512x16 +SUBPR n/a 1:01 10 conn/discon 6.1 sec/proc +IPCO 0.6 0:04 100 getpars +IPCB 2.1 0:13 1E6 bytes 76.9 Kb/sec +FORTSK n/a 0:31 10 commands 3.1 sec/cmd +WBIN 5.0 2:41 5E6 bytes 31.1 Kb/sec +RBIN 2.4 0:25 5E6 bytes 200.0 Kb/sec +RRBIN 0.8 0:28 5E6 bytes 178.6 Kb/sec +WTEXT 24.75 0:57 1E6 bytes 17.5 Kb/sec +RTEXT 23.92 0:30 1E6 bytes 33.3 Kb/sec +NWBIN n/a +NRBIN n/a +NWNULL n/a +NWTEXT n/a +NRTEXT n/a +PLOTS n/a 0:16 10 plots 1.6 sec/PROW +2USER n/a 0:24 10 plots 2.4 sec/PROW +4USER +.fi + + +Notes: +.ls [1] +These benchmarks were run with the disks very nearly full and badly +fragmented, hence the i/o performance of the system was much worse than it +might otherwise be. +.le +.ls [2] +The CLSS given is for a single user on the system. With one user already +logged into IRAF, the CLSS was 0:18. +.le + +.bp + . +.sp 20 +.ce +APPENDIX 2. IRAF VERSION 2.2 BENCHMARKS +.ce +March 1986 + +.bp +.sh +UNIX/IRAF V2.2 4.2BSD UNIX, VAX 11/750+FPA RA81 (lyra) +.br +CPU times are given in seconds, CLK times in minutes and seconds. +.br +Saturday, 22 March, D. Tody, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes \fR + (user+sys) (m:ss) + +CLSS 06.8+04.0 0:13 +MKPKGV 24.5+26.0 1:11 +MKPKGC 160.5+67.4 4:33 +MKHDB 25.1+? 0:41 +IMADDS 3.3+? 0:08 512x512x16 +IMADDR 4.4 0:15 512x512x32 +IMSTATR 23.6 0:29 512x512x32 +IMSHIFTR 116.3 2:14 512x512x32 +IMLOAD 9.6 0:15 512x512x16 +IMLOADF 3.9 0:08 512x512x16 +IMTRAN 9.8 0:16 512x512x16 +SUBPR - 0:28 10 conn/discon 2.8 sec/proc +IPCO 1.3 0:08 100 getpars +IPCB 2.5 0:16 1E6 bytes 62.5 Kb/sec +FORTSK 4.4 0:22 10 commands 2.2 sec/cmd +WBIN 4.8 0:23 5E6 bytes 217.4 Kb/sec +RBIN 4.4 0:22 5E6 bytes 227.3 Kb/sec +RRBIN 0.2 0:20 5E6 bytes 250.0 Kb/sec +WTEXT 37.2 0:43 1E6 bytes 23.2 Kb/sec +RTEXT 32.2 0:37 1E6 bytes 27.2 Kb/sec +NWBIN 5.1 2:01 5E6 bytes 41.3 Kb/sec +NRBIN 8.3 2:13 5E6 bytes 37.6 Kb/sec +NWNULL 5.1 1:55 5E6 bytes 43.5 Kb/sec +NWTEXT 40.5 1:15 1E6 bytes 13.3 Kb/sec +NRTEXT 24.8 2:15 1E6 bytes 7.4 Kb/sec +PLOTS - 0:25 10 plots 2.5 clk/PROW +2USER - 0:43 +4USER - 1:24 +.fi + + +Notes: +.ls [1] +All cpu timings from MKHDB on do not include the "system" time. +.le +.ls [2] +4.3BSD UNIX, due out shortly, reportedly differs from 4.2 mostly in that +a number of efficiency improvements have been made. These benchmarks will +be rerun as soon as 4.3BSD becomes available. +.le +.ls [3] +In UNIX/IRAF V2.2, IPC communications are implemented with pipes which +are really sockets (a much more sophisticated mechanism than we need), +which accounts for the relatively low IPC bandwidth. +.le +.ls [4] +The remote node used for the network tests was aquila, a VAX 11/750 running +4.2 BSD UNIX. The network protocol used was TCP/IP. +.le +.ls [5] +The i/o bandwidth to disk should be improved dramatically when we implement +the planned "static file driver" for UNIX. This will provide direct, +asynchronous i/o for large preallocated binary files which do not change +in size after creation. The use of the global buffer cache by the UNIX +read and write system services is the one major shortcoming of the UNIX +system for image processing applications. +.le + +.bp +.sh +VMS/IRAF V2.2, VMS V4.3, VAX 11/750+FPA RA81/Clustered (vela) +.br +Wednesday, 26 March, D. Tody, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes \fR + (user+sys) (m:ss) + +CLSS 14.4 0:40 +MKPKGV 260.0 6:05 +MKPKGC - 4:51 +MKHDB 40.9 1:05 +IMADDS 6.4 0:10 512x512x16 +IMADDR 6.5 0:13 512x512x32 +IMSTATR 15.8 0:18 512x512x32 +IMSHIFTR 68.2 1:17 512x512x32 +IMLOAD 10.6 0:15 512x512x16 +IMLOADF 4.1 0:07 512x512x16 +IMTRAN 14.4 0:20 512x512x16 +SUBPR - 1:03 10 conn/discon 6 sec/subpr +IPCO 1.4 0:06 100 getpars +IPCB 2.8 0:07 1E6 bytes 143 Kb/sec +FORTSK - 0:35 10 commands 3.5 sec/cmd +WBIN (ra81)Cl 6.7 0:20 5E6 bytes 250 Kb/sec +RBIN (ra81)Cl 5.1 0:12 5E6 bytes 417 Kb/sec +RRBIN (ra81)Cl 1.8 0:10 5E6 bytes 500 Kb/sec +WBIN (rm80) 6.8 0:17 5E6 bytes 294 Kb/sec +RBIN (rm80) 5.1 0:13 5E6 bytes 385 Kb/sec +RRBIN (rm80) 1.8 0:09 5E6 bytes 556 Kb/sec +WTEXT 65.6 1:19 1E6 bytes 13 Kb/sec +RTEXT 32.5 0:34 1E6 bytes 29 Kb/sec +NWBIN (not available) +NRBIN (not available) +NWNULL (not available) +NWTEXT (not available) +NRTEXT (not available) +PLOTS - 0:24 10 plots +2USER - 0:43 +4USER - 2:13 response was somewhat erratic +.fi + + +Notes: + +.ls [1] +The interactive response of this system seemed to decrease markedly either +when it was converted to 4.x VMS or when it was clustered with our 8600. +In interactive applications which involve a lot of process spawns and other +system calls, the system tends to spend about half of the available cpu time +in kernel mode even if there are only a few active users. These problems +are much less noticeable on an 8600 or even on a 780, hence one wonders if +VMS has perhaps become too large and complicated for the relatively slow 11/750, +at least when used in a VAX-cluster configuration. +.le +.ls [2] +Compare the 2USER and 4USER timings with those for the UNIX 11/750. This +benchmark is characteristic of the two systems. No page faulting was evident +on the VMS 11/750 during the multiuser benchmarks. It took much longer to +run the 4USER benchmark on the VMS 750, as the set up time was much longer +once one or two other PLOTS jobs were running. The UNIX machine, on the other +hand, seemed almost as fast (or as slow) as usual, even with the PLOTS jobs +running on the other terminals. +.le +.ls [3] +The RA81 was clustered with the 8600, whereas the RM80 was directly connected +to the 11/750. +.le +.ls [4] +The high value of the IPC bandwidth for VMS is due to the use of shared +memory. Mailboxes were considerably slower and are no longer used. +.le +.ls [5] +The foreign task interface uses mailboxes to talk to a DCL run as a subprocess +and should be considerably faster than it is. It is slow at present due to +the need to call SET MESSAGE before and after the user command to disable +pointless DCL error messages having to do with logical names. +.le + +.bp +.sh +VMS/IRAF V2.2, VMS V4.3, VAX 8600 RA81/Clustered (draco) +.br +Saturday, 22 March, D. Tody, NOAO/Tucson + +.nf +\fBBenchmark CPU CLK Size Notes \fR + (user+sys) (m:ss) + +CLSS 2.4 0:08 +MKPKGV 48.0 1:55 +MKPKGC - 1:30 +MKHDB 7.1 0:21 +IMADDS 1.2 0:04 512x512x16 +IMADDR 1.5 0:08 512x512x32 +IMSTATR 3.0 0:05 512x512x32 +IMSHIFTR 13.6 0:20 512x512x32 +IMLOAD 2.8 0:07 512x512x16 via TCP/IP to lyra +IMLOADF 1.3 0:07 512x512x16 via TCP/IP to lyra +IMTRAN 3.2 0:07 512x512x16 +SUBPR - 0:26 10 conn/discon 2.6 sec/proc +IPCO 0.0 0:02 100 getpars +IPCB 0.3 0:07 1E6 bytes 142.9 Kb/sec +FORTSK - 0:13 10 commands 1.3 sec/cmd +WBIN (RA81)Cl 1.3 0:13 5E6 bytes 384.6 Kb/sec +RBIN (RA81)Cl 1.1 0:08 5E6 bytes 625.0 Kb/sec +RRBIN (RA81)Cl 0.3 0:07 5E6 bytes 714.0 Kb/sec +WTEXT 10.7 0:20 1E6 bytes 50.0 Kb/sec +RTEXT 5.2 0:05 1E6 bytes 200.0 Kb/sec +NWBIN 1.8 1:36 5E6 bytes 52.1 Kb/sec +NRBIN 8.0 2:06 5E6 bytes 39.7 Kb/sec +NWNULL 2.5 1:20 5E6 bytes 62.5 Kb/sec +NWTEXT 6.5 0:43 1E6 bytes 23.3 Kb/sec +NRTEXT 5.9 1:39 1E6 bytes 10.1 Kb/sec +PLOTS - 0:06 10 plots 0.6 sec/PROW +2USER - 0:08 +4USER - 0:14 +.fi + + +Notes: + +.ls [1] +Installed images were not used for these benchmarks; the CLSS timing +should be slightly improved if the CL image is installed. +.le +.ls [2] +The image display was accessed via the network (IRAF TCP/IP network interface, +Wollongong TCP/IP package for VMS), with the IIS image display residing on +node lyra and accessed via a UNIX/IRAF kernel server. The binary and text +file network tests also used lyra as the remote node. +.le +.ls [3] +The high value of the IPC bandwidth for VMS is due to the use of shared +memory. Mailboxes were considerably slower and are no longer used. +.le +.ls [4] +The foreign task interface uses mailboxes to talk to a DCL run as a +subprocess and should be considerably faster than it is. It is slow at +present due to the need to call SET MESSAGE before and after the user +command to disable pointless DCL error messages having to do with +logical names. +.le +.ls [5] +The cpu on the 8600 is so fast, compared to the fairly standard VAX i/o +channels, that most tasks are i/o bound. The system can therefore easily +support several heavy users before much degradation in performance is seen +(provided they access data stored on different disks to avoid a disk seek +bottleneck). This is borne out in the 2USER and 4USER benchmarks shown above. +The cpu did not become saturated until the fourth user was added in this +particular benchmark. +.le diff --git a/pkg/bench/bench.ms b/pkg/bench/bench.ms new file mode 100644 index 00000000..1dc6ebf7 --- /dev/null +++ b/pkg/bench/bench.ms @@ -0,0 +1,788 @@ +.RP +.TL +A Set of Benchmarks for Measuring IRAF System Performance +.AU +Doug Tody +.AI +.K2 "" "" "*" +March 1986 +.br +(Revised July 1987) + +.AB +.ti 0.75i +This paper presents a set of benchmarks for measuring the performance of +IRAF as installed on a particular host system. The benchmarks serve two +purposes: [1] they provide an objective means of comparing the performance of +different IRAF host systems, and [2] the benchmarks may be repeated as part of +the IRAF installation procedure to verify that the expected performance is +actually being achieved. While the benchmarks chosen are sometimes complex, +i.e., at the level of actual applications programs and therefore difficult to +interpret in detail, some effort has been made to measure all the important +performance characteristics of the host system. These include the raw cpu +speed, the floating point processing speed, the i/o bandwidth to disk, and a +number of characteristics of the host operating system as well, e.g., the +efficiency of common system calls, the interactive response of the system, +and the response of the system to loading. The benchmarks are discussed in +detail along with instructions for benchmarking a new system, followed by +tabulated results of the benchmarks for a number of IRAF host machines. +.AE + +.pn 1 +.bp +.ce +\fBContents\fR +.sp 3 +.sp +1.\h'|0.4i'\fBIntroduction\fP\l'|5.6i.'\0\01 +.sp +2.\h'|0.4i'\fBWhat is Measured\fP\l'|5.6i.'\0\02 +.sp +3.\h'|0.4i'\fBThe Benchmarks\fP\l'|5.6i.'\0\03 +.br +\h'|0.4i'3.1.\h'|0.9i'Host Level Benchmarks\l'|5.6i.'\0\03 +.br +\h'|0.9i'3.1.1.\h'|1.5i'CL Startup/Shutdown [CLSS]\l'|5.6i.'\0\03 +.br +\h'|0.9i'3.1.2.\h'|1.5i'Mkpkg (verify) [MKPKGV]\l'|5.6i.'\0\04 +.br +\h'|0.9i'3.1.3.\h'|1.5i'Mkpkg (compile) [MKPKGC]\l'|5.6i.'\0\04 +.br +\h'|0.4i'3.2.\h'|0.9i'IRAF Applications Benchmarks\l'|5.6i.'\0\04 +.br +\h'|0.9i'3.2.1.\h'|1.5i'Mkhelpdb [MKHDB]\l'|5.6i.'\0\05 +.br +\h'|0.9i'3.2.2.\h'|1.5i'Sequential Image Operators [IMADD, IMSTAT, etc.]\l'|5.6i.'\0\05 +.br +\h'|0.9i'3.2.3.\h'|1.5i'Image Load [IMLOAD,IMLOADF]\l'|5.6i.'\0\05 +.br +\h'|0.9i'3.2.4.\h'|1.5i'Image Transpose [IMTRAN]\l'|5.6i.'\0\06 +.br +\h'|0.4i'3.3.\h'|0.9i'Specialized Benchmarks\l'|5.6i.'\0\06 +.br +\h'|0.9i'3.3.1.\h'|1.5i'Subprocess Connect/Disconnect [SUBPR]\l'|5.6i.'\0\07 +.br +\h'|0.9i'3.3.2.\h'|1.5i'IPC Overhead [IPCO]\l'|5.6i.'\0\07 +.br +\h'|0.9i'3.3.3.\h'|1.5i'IPC Bandwidth [IPCB]\l'|5.6i.'\0\07 +.br +\h'|0.9i'3.3.4.\h'|1.5i'Foreign Task Execution [FORTSK]\l'|5.6i.'\0\07 +.br +\h'|0.9i'3.3.5.\h'|1.5i'Binary File I/O [WBIN,RBIN,RRBIN]\l'|5.6i.'\0\07 +.br +\h'|0.9i'3.3.6.\h'|1.5i'Text File I/O [WTEXT,RTEXT]\l'|5.6i.'\0\08 +.br +\h'|0.9i'3.3.7.\h'|1.5i'Network I/O [NWBIN,NRBIN,etc.]\l'|5.6i.'\0\08 +.br +\h'|0.9i'3.3.8.\h'|1.5i'Task, IMIO, GIO Overhead [PLOTS]\l'|5.6i.'\0\09 +.br +\h'|0.9i'3.3.9.\h'|1.5i'System Loading [2USER,4USER]\l'|5.6i.'\0\09 +.sp +4.\h'|0.4i'\fBInterpreting the Benchmark Results\fP\l'|5.6i.'\0\010 +.sp +\fBAppendix A: IRAF Version 2.5 Benchmarks\fP +.sp +\fBAppendix B: IRAF Version 2.2 Benchmarks\fP + +.nr PN 0 +.bp +.NH +Introduction +.PP +This set of benchmarks has been prepared with a number of purposes in mind. +Firstly, the benchmarks may be run after installing IRAF on a new system to +verify that the performance expected for that machine is actually being +achieved. In general, this cannot be taken for granted since the performance +actually achieved on a particular system may depend upon how the system +is configured and tuned. Secondly, the benchmarks may be run to compare +the performance of different IRAF hosts, or to track the system performance +over a period of time as improvements are made, both to IRAF and to the host +system. Lastly, the benchmarks provide a metric which can be used to tune +the host system. +.PP +All too often, the only benchmarks run on a system are those which test the +execution time of optimized code generated by the host Fortran compiler. +This is primarily a hardware benchmark and secondarily a test of the Fortran +optimizer. An example of this type of test is the famous Linpack benchmark. +.PP +The numerical execution speed test is an important benchmark but it tests only +one of the many factors contributing to the overall performance of the system +as perceived by the user. In interactive use other factors are often more +important, e.g., the time required to spawn or communicate with a subprocess, +the time required to access a file, the response of the system as the number +of users (or processes) increases, and so on. While the quality of optimized +code is significant for cpu intensive batch processing, other factors are +often more important for sophisticated interactive applications. +.PP +The benchmarks described here are designed to test, as fully as possible, +the major factors contributing to the overall performance of the IRAF system +on a particular host. A major factor in the timings of each benchmark is +of course the IRAF system itself, but comparisons of different hosts are +nonetheless possible since the code is virtually identical on all hosts +(the applications and VOS are in fact identical on all hosts). +The IRAF kernel (OS interface) is coded differently for each host operating +system, but the functions performed by the kernel are identical on each host, +and since the kernel is a very "thin" layer the kernel code itself is almost +always a negligible factor in the final timings. +.PP +The IRAF version number, host operating system and associated version number, +and the host computer hardware configuration are all important in interpreting +the results of the benchmarks, and should always be recorded. + +.NH +What is Measured +.PP +Each benchmark measures two quantities, the total cpu time required to +execute the benchmark, and the total (wall) clock time required to execute the +benchmark. If the clock time measurement is to be of any value the benchmarks +must be run on a single user system. Given this "best time" measurement +and some idea of how the system responds to loading, it is not difficult to +estimate the performance to be expected on a loaded system. +.PP +The total cpu time required to execute a benchmark consists of the "user" time +plus the "system" time. The "user" time is the cpu time spent executing +the instructions comprising the user (IRAF) program, i.e., any instructions +in procedures linked directly into the process being executed. The "system" +time is the cpu time spent in kernel mode executing the system services called +by the user program. On some systems there is no distinction between the two +types of timings, with the system time either being included in the measured +cpu time, or omitted from the timings. If the benchmark involves several +concurrent processes no cpu time measurement of the subprocesses may be +possible on some systems. +.PP +When possible we give both measurements, while in some cases only the user +time is given, or only the sum of the user and system times. The cpu time +measurements are therefore only directly comparable between different +operating systems for the simpler benchmarks, in particular those which make +few system calls. The cpu measurements given \fIare\fR accurate for the same +operating system (e.g., some version of UNIX) running on different hosts, +and may be used to compare such systems. Reliable comparisions between +different operating systems are also possible, but only if one thoroughly +understands what is going on. +.PP +The clock time measurement includes both the user and system times, plus the +time spent waiting for i/o. Any minor system daemon processes executing while +the benchmarks are being run may bias the clock time measurement slightly, +but since these are a constant part of the host environment it is fair to +include them in the timings. Major system daemons which run infrequently +(e.g., the print symbiont in VMS) should invalidate the benchmark. +.PP +Assuming an otherwise idle system, a comparison of the cpu and clock times +tells whether the benchmark was cpu bound or i/o bound. Those benchmarks +involving compiled IRAF tasks do not include the process startup and pagein +times (these are measured by a different benchmark), hence the task should be +run once before running the benchmark to connect the subprocess and page in +the memory used by the task. A good procedure to follow is to run each +benchmark once to start the process, and then repeat the benchmark three times, +averaging the results. If inconsistent results are obtained further iterations +and/or monitoring of the host system are called for until a consistent result +is achieved. +.PP +Many benchmarks depend upon disk performance as well as compute cycles. +For such a benchmark to be a meaningful measure of the i/o bandwidth of the +system it is essential that no other users (or batch jobs) be competing for +disk seeks on the disk used for the test file. There are subtle things to +watch out for in this regard, for example, if the machine is in a VMS cluster +or on a local area network, processes on other nodes may be accessing the +local disk, yet will not show up on a user login or process list on the local +node. It is always desirable to repeat each test several times or on several +different disk devices, to ensure that no outside requests were being serviced +while the benchmark was being run. If the system has disk monitoring utilities +use these to find an idle disk before running any benchmarks which do heavy i/o. +.PP +Beware of disks which are nearly full; the maximum achievable i/o bandwidth +may fall off rapidly as a disk fills up, due to disk fragmentation (the file +must be stored in little pieces scattered all over the physical disk). +Similarly, many systems (VMS, AOS/VS, V7 and Sys V UNIX, but not Berkeley UNIX) +suffer from disk fragmentation problems that gradually worsen as a files system +ages, requiring that the disk periodically be backed off onto tape and then +restored to render the files and free spaces as contiguous as possible. +In some cases, disk fragmentation can cause the maximum achievable i/o +bandwidth to degrade by an order of magnitude. For example, on a VMS system +one can use \fLCOPY/CONTIGUOUS\fR to render files contiguous (e.g., this can +be done on all the executables in \fL[IRAF.BIN]\fR after installing the +system, to speed process pagein times). If the copy fails for a large file +even though there is substantial free space left on the disk, the disk is +badly fragmented. + +.NH +The Benchmarks +.PP +Instructions are given for running each benchmark, and the operations +performed by each benchmark are briefly described. The system characteristics +measured by the benchmark are briefly discussed. A short mnemonic name is +associated with each benchmark to identify it in the tables given in the +appendices, tabulating the results for actual host machines. + +.NH 2 +Host Level Benchmarks +.PP +The benchmarks discussed in this section are run at the host system level. +The examples are given for the UNIX cshell, under the assumption that a host +dependent example is better than none at all. These commands must be +translated by the user to run the benchmarks on a different system +(hint: use \fLSHOW STATUS\fR or a stop watch to measure wall clock times +on a VMS host). +.NH 3 +CL Startup/Shutdown [CLSS] +.PP +Go to the CL login directory (any directory containing a \fLLOGIN.CL\fR file), +mark the time (the method by which this is done is system dependent), +and startup the CL. Enter the "logout" command while the CL is starting up +so that the CL will not be idle (with the clock running) while the command +is being entered. Mark the final cpu and clock time and compute the +difference. +.DS +\fL% time cl +logout\fR +.DE +.LP +This is a complex benchmark but one which is of obvious importance to the +IRAF user. The benchmark is probably dominated by the cpu time required to +start up the CL, i.e., start up the CL process, initialize the i/o system, +initialize the environment, interpret the CL startup file, interpret the +user LOGIN.CL file, connect and disconnect the x_system.e subprocess, and so on. +Most of the remaining time is the overhead of the host operating system for +the process spawns, page faults, file accesses, and so on. +\fIDo not use a customized \fLLOGIN.CL\fP file when running this benchmark\fR, +or the timings will almost certainly be affected. +.NH 3 +Mkpkg (verify) [MKPKGV] +.PP +Go to the PKG directory and enter the (host system equivalent of the) +following command. The method by which the total cpu and clock times are +computed is system dependent. +.DS +\fL% cd $iraf/pkg +% time mkpkg -n\fR +.DE +.LP +This benchmark does a "no execute" make-package of the entire PKG suite of +applications and systems packages. This tests primarily the speed with which +the host system can read directories, resolve pathnames, and return directory +information for files. Since the PKG directory tree is continually growing, +this benchmark is only useful for comparing the same version of IRAF run on +different hosts, or the same version of IRAF on the same host at different +times. +.NH 3 +Mkpkg (compile) [MKPKGC] +.PP +Go to the directory "iraf$pkg/bench/xctest" and enter the (host system +equivalents of the) following commands. The method by which the total cpu +and clock times are computed is system dependent. Only the \fBmkpkg\fR +command should be timed. +.DS +\fL +% cd $iraf/pkg/bench/xctest +% mkpkg clean # delete old library, etc., if present +% time mkpkg +% mkpkg clean # delete newly created binaries\fR +.DE +.LP +This tests the time required to compile and link a small IRAF package. +The timings reflect the time required to preprocess, compile, optimize, +and assemble each module and insert it into the package library, then link +the package executable. The host operating system overhead for the process +spawns, page faults, etc. is also a major factor. If the host system +provides a shared library facility this will significantly affect the link +time, hence the benchmark should be run linking both with and without shared +libraries to make a fair comparison to other systems. Linking against a +large library is fastest if the library is topologically sorted and stored +contiguously on disk. + +.NH 2 +IRAF Applications Benchmarks +.PP +The benchmarks discussed in this section are run from within the IRAF +environment, using only standard IRAF applications tasks. The cpu and clock +times of any (compiled) IRAF task may be measured by prefixing the task name +with a $ when the command is entered into the CL, as shown in the examples. +The significance of the cpu time measurement is not precisely defined for +all systems. On a UNIX host, it is the "user" cpu time used by the task. +On a VMS host, there does not appear to be any distinction between the user +and system times (probably because the system services execute in the context +of the calling process), hence the cpu time given probably includes both, +but probably excludes the time for any services executing in ancillary +processes, e.g., for RMS. +.NH 3 +Mkhelpdb [MKHDB] +.PP +The \fBmkhelpdb\fR task is in the \fBsoftools\fR package. The function of +the task is to scan the tree of ".hd" help-directory files and compile the +binary help database. +.DS +\fLcl> softools +cl> $mkhelpdb +.DE +.LP +This benchmark tests the speed of the host files system and the efficiency of +the host system services and text file i/o, as well as the global optimization +of the Fortran compiler and the MIPS rating of the host machine. +Since the size of the help database varies with each version of IRAF, +this benchmark is only useful for comparing the same version of IRAF run +on different hosts, or the same version run on a single host at different +times. Note than any additions to the base IRAF system (e.g., SDAS) will +increase the size of the help database and affect the timings. +.NH 3 +Sequential Image Operators [IMADDS,IMADDR,IMSTATR,IMSHIFTR] +.PP +These benchmarks measure the time required by typical image operations. +All tests should be performed on 512 square test images created with the +\fBimdebug\fR package. The \fBimages\fR and \fBimdebug\fR packages should +be loaded. Enter the following commands to create the test images. +.DS +\fLcl> mktest pix.s s 2 "512 512" +cl> mktest pix.r r 2 "512 512"\fR +.DE +.LP +The following benchmarks should be run on these test images. Delete the +output images after each benchmark is run. If you enter the commands shown +once, the command can be repeated by typing \fL^\fR followed by return. +Each benchmark should be run several times, discarding the first timing and +averaging the remaining timings for the final result. +.DS +.TS +l l. +[IMADDS] \fLcl> $imarith pix.s + 5 pix2.s; imdel pix2.s\fR +[IMADDR] \fLcl> $imarith pix.r + 5 pix2.r; imdel pix2.r\fR +[IMSTATR] \fLcl> $imstat pix.r\fR +[IMSHIFTR] \fLcl> $imshift pix.r pix2.r .33 .44 interp=spline3\fR +.TE +.DE +.LP +The IMADD benchmarks test the efficiency of the image i/o system, including +binary file i/o, and provide an indication of how long a simple disk to disk +image operation takes on the system in question. This benchmark should be +i/o bound on most systems. The IMSTATR and IMSHIFTR benchmarks are normally +cpu bound, and test primarily the speed of the host cpu and floating point +unit, and the quality of the code generated by the host Fortran compiler. +Note that the IMSHIFTR benchmark employs a true two dimensional bicubic spline, +hence the timings are a factor of 4 greater than one would expect if a one +dimensional interpolator were used to shift the two dimensional image. +.NH 3 +Image Load [IMLOAD,IMLOADF] +.PP +To run the image load benchmarks, first load the \fBtv\fR package and +display something to get the x_display.e process into the process cache. +Run the following two benchmarks, displaying the test image PIX.S (this image +contains a test pattern of no interest). +.DS +.TS +l l. +[IMLOAD] \fLcl> $display pix.s 1\fR +[IMLOADF] \fLcl> $display pix.s 1 zt=none\fR +.TE +.DE +.LP +The IMLOAD benchmark measures how long it takes for a normal image load on +the host system, including the automatic determination of the greyscale +mapping, and the time required to map and clip the image pixels into the +8 bits (or whatever) displayable by the image display. This benchmark +measures primarily the cpu speed and i/o bandwidth of the host system. +The IMLOADF benchmark eliminates the cpu intensive greyscale transformation, +yielding the minimum image display time for the host system. +.NH 3 +Image Transpose [IMTRAN] +.PP +To run this benchmark, transpose the image PIX.S, placing the output in a +new image. +.DS +\fLcl> $imtran pix.s pix2.s\fR +.DE +.LP +This benchmark tests the ability of a process to grab a large amount of +physical memory (large working set), and the speed with which the host system +can service random rather than sequential file access requests. The user +working set should be large enough to avoid excessive page faulting. + +.NH 2 +Specialized Benchmarks +.PP +The next few benchmarks are implemented as tasks in the \fBbench\fR package, +located in the directory "pkg$bench". This package is not installed as a +predefined package as the standard IRAF packages are. Since this package is +used infrequently the binaries may have been deleted; if the file x_bench.e is +not present in the \fIbench\fR directory, rebuild it as follows: +.DS +\fLcl> cd pkg$bench +cl> mkpkg\fR +.DE +.LP +To load the package, enter the following commands. It is not necessary to +\fIcd\fR to the bench directory to load or run the package. +.DS +\fLcl> task $bench = "pkg$bench/bench.cl" +cl> bench +.DE +.LP +This defines the following benchmark tasks. There are no manual pages for +these tasks; the only documentation is what you are reading. +.DS +.TS +l l. +FORTASK - foreign task execution +GETPAR - get parameter; tests IPC overhead +PLOTS - make line plots from an image +RBIN - read binary file; tests FIO bandwidth +RRBIN - raw (unbuffered) binary file read +RTEXT - read text file; tests text file i/o speed +SUBPROC - subprocess connect/disconnect +WBIN - write binary file; tests FIO bandwidth +WIPC - write to IPC; tests IPC bandwidth +WTEXT - write text file; tests text file i/o speed +.TE +.DE +.NH 3 +Subprocess Connect/Disconnect [SUBPR] +.PP +To run the SUBPR benchmark, enter the following command. +This will connect and disconnect the x_images.e subprocess 10 times. +Difference the starting and final times printed as the task output to get +the results of the benchmark. The cpu time measurement may be meaningless +(very small) on some systems. +.DS +\fLcl> subproc 10\fR +.DE +This benchmark measures the time required to connect and disconnect an +IRAF subprocess. This includes not only the host time required to spawn +and later shutdown a process, but also the time required by the IRAF VOS +to set up the IPC channels, initialize the VOS i/o system, initialize the +environment in the subprocess, and so on. A portion of the subprocess must +be paged into memory to execute all this initialization code. The host system +overhead to spawn a subprocess and fault in a portion of its address space +is a major factor in this benchmark. +.NH 3 +IPC Overhead [IPCO] +.PP +The \fBgetpar\fR task is a compiled task in x_bench.e. The task will +fetch the value of a CL parameter 100 times. +.DS +\fLcl> $getpar 100\fR +.DE +Since each parameter access consists of a request sent to the CL by the +subprocess, followed by a response from the CL process, with a negligible +amount of data being transferred in each call, this tests the IPC overhead. +.NH 3 +IPC Bandwidth [IPCB] +.PP +To run this benchmark enter the following command. The \fBwipc\fR task +is a compiled task in x_bench.e. +.DS +\fLcl> $wipc 1E6 > dev$null\fR +.DE +This writes approximately 1 Mb of binary data via IPC to the CL, which discards +the data (writes it to the null file via FIO). Since no actual disk file i/o is +involved, this tests the efficiency of the IRAF pseudofile i/o system and of the +host system IPC facility. +.NH 3 +Foreign Task Execution [FORTSK] +.PP +To run this benchmark enter the following command. The \fBfortask\fR +task is a CL script task in the \fBbench\fR package. +.DS +\fLcl> fortask 10\fR +.DE +This benchmark executes the standard IRAF foreign task \fBrmbin\fR (one of the +bootstrap utilities) 10 times. The task is called with no arguments and does +nothing other than execute, print out its "usage" message, and shut down. +This tests the time required to execute a host system task from within the +IRAF environment. Only the clock time measurement is meaningful. +.NH 3 +Binary File I/O [WBIN,RBIN,RRBIN] +.PP +To run these benchmarks, make sure the \fBbench\fR package is loaded, and enter +the following commands. The \fBwbin\fR, \fBrbin\fR and \fBrrbin\fR tasks are +compiled tasks in x_bench.e. A binary file named BINFILE is created in the +current directory by WBIN, and should be deleted after the benchmark has been +run. Each benchmark should be run at least twice before recording the time +and moving on to the next benchmark. Successive calls to WBIN will +automatically delete the file and write a new one. +.PP +\fINOTE:\fR it is wise to create the test file on a files system which has +a lot of free space available, to avoid disk fragmentation problems. +Also, if the host system has two or more different types of disk drives +(or disk controllers or bus types), you may wish to run the benchmark +separately for each drive. +.DS +\fLcl> $wbin binfile 5E6 +cl> $rbin binfile +cl> $rrbin binfile +cl> delete binfile # (not part of the benchmark)\fR +.DE +.LP +These benchmarks measure the time required to write and then read a binary disk +file approximately 5 Mb in size. This benchmark measures the binary file i/o +bandwidth of the FIO interface (for sequential i/o). In WBIN and RBIN the +common buffered READ and WRITE requests are used, hence some memory to memory +copying is included in the overhead measured by the benchmark. A large FIO +buffer is used to minimize disk seeks and synchronization delays; somewhat +faster timings might be possible by increasing the size of the buffer +(this is not a user controllable option, and is not possible on all host +systems). The RRBIN benchmark uses ZARDBF to read the file in chunks of +32768 bytes, giving an estimate of the maximum i/o bandwidth for the system. +.NH 3 +Text File I/O [WTEXT,RTEXT] +.PP +To run these benchmarks, load the \fBbench\fR package, and then enter the +following commands. The \fBwtext\fR and \fBrtext\fR tasks are compiled tasks +in x_bench.e. A text file named TEXTFILE is created in the current directory +by WTEXT, and should be deleted after the benchmarks have been run. +Successive calls to WTEXT will automatically delete the file and write a new +one. +.DS +\fLcl> $wtext textfile 1E6 +cl> $rtext textfile +cl> delete textfile # (not part of the benchmark)\fR +.DE +.LP +These benchmarks measure the time required to write and then read a text disk +file approximately one megabyte in size (15,625 64 character lines). +This benchmark measures the efficiency with which the system can sequentially +read and write text files. Since text file i/o requires the system to pack +and unpack records, text i/o tends to be cpu bound. +.NH 3 +Network I/O [NWBIN,NRBIN,NWNULL,NWTEXT,NRTEXT] +.PP +These benchmarks are equivalent to the binary and text file benchmarks +just discussed, except that the binary and text files are acccessed on a +remote node via the IRAF network interface. The calling sequences are +identical except that an IRAF network filename is given instead of referencing +a file in the current directory. For example, the following commands would +be entered to run the network binary file benchmarks on node LYRA (the node +name and filename are site dependent). +.DS +\fLcl> $wbin lyra!/tmp3/binfile 5E6 \fR[NWBIN]\fL +cl> $rbin lyra!/tmp3/binfile \fR[NRBIN]\fL +cl> $wbin lyra!/dev/null 5E6 \fR[NWNULL]\fL +cl> delete lyra!/tmp3/binfile\fR +.DE +.LP +The text file benchmarks are equivalent with the obvious changes, i.e., +substitute "text" for "bin", "textfile" for "binfile", and omit the null +textfile benchmark. The type of network interface used (TCP/IP, DECNET, etc.), +and the characteristics of the remote node should be recorded. +.PP +These benchmarks test the bandwidth of the IRAF network interfaces for binary +and text files, as well as the limiting speed of the network itself (NWNULL). +The binary file benchmarks should be i/o bound. NWBIN should outperform +NRBIN since a network write is a pipelined operation, whereas a network read +is (currently) a synchronous operation. Text file access may be either cpu +or i/o bound depending upon the relative speeds of the network and host cpus. +The IRAF network interface buffers textfile i/o to minimize the number of +network packets and maximize the i/o bandwidth. +.NH 3 +Task, IMIO, GIO Overhead [PLOTS] +.PP +The \fBplots\fR task is a CL script task which calls the \fBprow\fR task +repeatedly to plot the same line of an image. The graphics output is +discarded (directed to the null file) rather than plotted since otherwise +the results of the benchmark would be dominated by the plotting speed of the +graphics terminal. +.DS +\fLcl> plots pix.s 10\fR +.DE +This is a complex benchmark. The benchmark measures the overhead of task +(not process) execution and the overhead of the IMIO and GIO subsystems, +as well as the speed with which IPC can be used to pass parameters to a task +and return the GIO graphics metacode to the CL. +.PP +The \fBprow\fR task is all overhead and is not normally used to interactively +plot image lines (\fBimplot\fR is what is normally used), but it is a good +task to use for a benchmark since it exercises the subsystems most commonly +used in scientific tasks. The \fBprow\fR task has a couple dozen parameters +(mostly hidden), must open the image to read the image line to be plotted +on every call, and must open the GIO graphics device on every call as well. +.NH 3 +System Loading [2USER,4USER] +.PP +This benchmark attempts to measure the response of the system as the +load increases. This is done by running large \fBplots\fR jobs on several +terminals and then repeating the 10 plots \fBplots\fR benchmark. +For example, to run the 2USER benchmark, login on a second terminal and +enter the following command, and then repeat the PLOTS benchmark discussed +in the last section. Be sure to use a different login or login directory +for each "user", to avoid concurrency problems, e.g., when reading the +input image or updating parameter files. +.DS +\fLcl> plots pix.s 9999\fR +.DE +Theoretically, the timings should be approximately .5 (2USER) and .25 (4USER) +as fast as when the PLOTS benchmark was run on a single user system, assuming +that cpu time is the limiting resource and that a single job is cpu bound. +In a case where there is more than one limiting resource, e.g., disk seeks as +well as cpu cycles, performance will fall off more rapidly. If, on the other +hand, a single user process does not keep the system busy, e.g., because +synchronous i/o is used, performance will fall off less rapidly. If the +system unexpectedly runs out of some critical system resource, e.g., physical +memory or some internal OS buffer space, performance may be much worse than +expected. +.PP +If the multiuser performance is poorer than expected it may be possible to +improve the system performance significantly once the reason for the poor +performance is understood. If disk seeks are the problem it may be possible +to distribute the load more evenly over the available disks. If the +performance decays linearly as more users are added and then gets really bad, +it is probably because some critical system resource has run out. Use the +system monitoring tools provided with the host operating system to try to +identify the critical resource. It may be possible to modify the system +tuning parameters to fix the problem, once the critical resource has been +identified. + +.NH +Interpreting the Benchmark Results +.PP +Many factors determine the timings obtained when the benchmarks are run +on a system. These factors include all of the following: +.sp +.RS +.IP \(bu +The hardware configuration, e.g., cpu used, clock speed, availability of +floating point hardware, type of floating point hardware, amount of memory, +number and type of disks, degree of fragmentation of the disks, bus bandwidth, +disk controller bandwidth, memory controller bandwidth for memory mapped DMA +transfers, and so on. +.IP \(bu +The host operating system, including the version number, tuning parameters, +user quotas, working set size, files system parameters, Fortran compiler +characteristics, level of optimization used to compile IRAF, and so on. +.IP \(bu +The version of IRAF being run. On a VMS system, are the images "installed" +to permit shared memory and reduce physical memory usage? Were the programs +compiled with the code optimizer, and if so, what compiler options were used? +Are shared libraries used if available on the host system? +.IP \(bu +Other activity in the system when the benchmarks were run. If there were no +other users on the machine at the time, how about batch jobs? If the machine +is on a cluster or network, were other nodes accessing the same disks? +How many other processes were running on the local node? Ideally, the +benchmarks should be run on an otherwise idle system, else the results may be +meaningless or next to impossible to interpret. Given some idea of how the +host system responds to loading, it is possible to estimate how a timing +will scale as the system is loaded, but the reverse operation is much more +difficult. +.RE +.sp +.PP +Because so many factors contribute to the results of a benchmark, it can be +difficult to draw firm conclusions from any benchmark, no matter how simple. +The hardware and software in modern computer systems is so complicated that +it is difficult even for an expert with a detailed knowledge and understanding +of the full system to explain in detail where the time is going, even when +running the simplest benchmark. On some recent message based multiprocessor +systems it is probably impossible to fully comprehend what is going on at any +given time, even if one fully understands how the system works, because of the +dynamic nature of such systems. +.PP +Despite these difficulties, the benchmarks do provide a coarse measure of the +relative performance of different host systems, as well as some indication of +the efficiency of the IRAF VOS. The benchmarks are designed to measure the +performance of the \fIhost system\fR (both hardware and software) in a number +of important areas, all of which play a role in determining the suitability of +a system for scientific data processing. The benchmarks are \fInot\fR +designed to measure the efficiency of the IRAF software itself (except parts +of the VOS), e.g., there is no measure of the time taken by the CL to compile +and execute a script, no measure of the speed of the median algorithm or of +an image transpose, and so on. These timings are also important, of course, +but should be measured separately. Also, measurements of the efficiency of +individual applications programs are much less critical than the performance +criteria dealt with here, since it is relatively easy to optimize an +inefficient or poorly designed applications program, even a complex one like +the CL, but there is generally little one can do about the host system. +.PP +The timings for the benchmarks for a number of host systems are given in the +appendices which follow. Sometimes there will be more than one set of +benchmarks for a given host system, e.g., because the system provided two or +more disks or floating point options with different levels of performance. +The notes at the end of each set of benchmarks are intended to document any +special features or problems of the host system which may have affected the +results. In general we did not bother to record things like system tuning +parameters, working set, page faults, etc., unless these were considered an +important factor in the benchmarks. In particular, few IRAF programs page +fault other than during process startup, hence this is rarely a signficant +factor when running these benchmarks (except possibly in IMTRAN). +.PP +Detailed results for each configuration of each host system are presented on +separate pages in the Appendices. A summary table showing the results of +selected benchmarks for all host systems at once is also provided. +The system characteristic or characteristics principally measured by each +benchmark is noted in the table below. This is only approximate, e.g., the +MIPS rating is a significant factor in all but the most i/o bound benchmarks. +.KS +.TS +center; +ci ci ci ci ci +l c c c c. +benchmark responsiveness mips flops i/o + +CLSS \(bu +MKPKGV \(bu +MKHDB \(bu \(bu +PLOTS \(bu \(bu +IMADDS \(bu \(bu +IMADDR \(bu \(bu +IMSTATR \(bu +IMSHIFTR \(bu +IMTRAN \(bu +WBIN \(bu +RBIN \(bu +.TE +.KE +.sp +.PP +By \fIresponsiveness\fR we refer to the interactive response of the system +as perceived by the user. A system with a good interactive response will do +all the little things very fast, e.g., directory listings, image header +listings, plotting from an image, loading new packages, starting up a new +process, and so on. Machines which score high in this area will seem fast +to the user, whereas machines which score poorly will \fIseem\fR slow, +sometimes frustratingly slow, even though they may score high in the areas +of floating point performance, or i/o bandwidth. The interactive response +of a system obviously depends upon the MIPS rating of the system (see below), +but an often more significant factor is the design and computational complexity +of the host operating system itself, in particular the time taken by the host +operating system to execute system calls. Any system which spends a large +fraction of its time in kernel mode will probably have poor interactive +response. The response of the system to loading is also very important, +i.e., if the system has trouble with load balancing as the number of users +(or processes) increases, response will become increasingly erratic until the +interactive response is hopelessly poor. +.PP +The MIPS column refers to the raw speed of the system when executing arbitrary +code containing a mixture of various types of instructions, but little floating +point, i/o, or system calls. A machine with a high MIPS rating will have a +fast cpu, e.g., a fast clock rate, fast memory access time, large cache memory, +and so on, as well as a good optimizing Fortran compiler. Assuming good +compilers, the MIPS rating is primarily a measure of the hardware speed of +the host machine, but all of the MIPS related benchmarks presented here also +make a significant number of system calls (MKHDB, for example, does a lot of +files accesses and text file i/o), hence it is not that simple. Perhaps a +completely cpu bound pure-MIPS benchmark should be added to our suite of +benchmarks (the MIPS rating of every machine is generally well known, however). +.PP +The FLOPS column identifies those benchmarks which do a significant amount of +floating point computation. The IMSHIFTR and IMSTATR benchmarks in particular +are heavily into floating point. These benchmarks measure the single +precision floating point speed of the host system hardware, as well as the +effectiveness of do-loop optimization by the host Fortran compiler. +The degree of optimization provided by the Fortran compiler can affect the +timing of these benchmarks by up to a factor of two. Note that the sample is +very small, and if a compiler fails to optimize the inner loop of one of these +benchmark programs, the situation may be reversed when running some other +benchmark. Any reasonable Fortran compiler should be able to optimize the +inner loop of the IMADDR benchmark, so the CPU timing for this benchmark is +a good measure of the hardware floating point speed, if one allows for do-loop +overhead, memory i/o, and the system calls necessary to access the image on +disk. +.PP +The I/O column identifies those benchmarks which are i/o bound and which +therefore provide some indication of the i/o bandwidth of the host system. +The i/o bandwidth actually achieved in these benchmarks depends upon +many factors, the most important of which are the host operating system +software (files system data structures and i/o software, disk drivers, etc.) +and the host system hardware, i.e., disk type, disk controller type, bus +bandwidth, and DMA memory controller bandwidth. Note that asynchronous i/o +is not currently used in these benchmarks, hence higher transfer rates are +probably possible in special cases (on a busy system all i/o is asynchronous +at the host system level anyway). Large transfers are used to minimize disk +seeks and synchronization delays, hence the benchmarks should provide a good +measure of the realistically achievable host i/o bandwidth. diff --git a/pkg/bench/bench_tab.ms b/pkg/bench/bench_tab.ms new file mode 100644 index 00000000..9245cbff --- /dev/null +++ b/pkg/bench/bench_tab.ms @@ -0,0 +1,98 @@ +.LP +.hm 0.25i +.nr HM 0.25i +.vs 10 +.nr VS 10 +.ll 9.0i +.nr LL 9.0i +.ps 9.0 +.nr PS 9.0 +.po 0.5i +.nr PO 0.5i +.bp +.LP +\fBIRAF V2.5 Table of Selected Benchmark Results May 1987\fR +.br +CPU and/or clock times are tabulated below for selected benchmark tests. +CPU times are given in seconds; clock times (in parentheses) are given +as (m:ss). For the WBIN and RBIN benchmarks, the tabulated result is +the measured bandwidth in Kbytes/second. For a description of the +benchmark tests, see the document "A Set of Benchmarks for Measuring +IRAF System Performance", Doug Tody, May l987. +.sp +.TS +cB cB cB cB s cB cB s cB s cB s cB s cB s cB cB +cB cB cB cB s cB cB s cB s cB s cB s cB s cB cB +lB |n| n| n n| n| n n| n n| n n| n n| n n| n| n|. + CLSS MKPKGV MKHDB PLOTS IMADDS IMADDR IMSTATR IMSHIFTR IMTRAN WBIN RBIN + _ _ _ _ _ _ _ _ _ _ _ + +ISI (0\&:03) (0\&:25) 6\&.00 (0\&:17) (0\&:10) 0\&.89 (0\&:05) 3\&.82 (0\&:10) 7\&.77 (0\&:10) 81\&.60 (1\&:29) 1\&.62 (0\&:06) 294.1 277.8 + +SUN3 (0\&:03) (0\&:17) 5\&.26 (0\&:10) (0\&:09) 0\&.62 (0\&:03) 3\&.34 (0\&:09) 8\&.38 (0\&:11) 83\&.44 (1\&:33) 1\&.47 (0\&:05) 625.0 454.5 + +SUN3+ (0\&:04) (0\&:19) 5\&.28 (0\&:11) (0\&:06) 0\&.63 (0\&:03) 0\&.86 (0\&:06) 5\&.1 (0\&:08) 31\&.1 (0\&:36) 1\&.5 (0\&:04) 714.3 454.5 + +U750 (0\&:17) (0\&:39) 22\&.79 (0\&:40) (0\&:29) 3\&.31 (0\&:10) 4\&.28 (0\&:17) 10\&.98 (0\&:15) 114\&.41 (2\&:13) 10\&.19 (0\&:17) 208.3 208.3 + +V750 (0\&:27) (4\&:17) 46\&.54 (1\&:11) (0\&:25) 5\&.90 (0\&:11) 6\&.48 (0\&:14) 10\&.65 (0\&:14) 69\&.62 (1\&:33) 14\&.85 (0\&:20) 238.1 384.6 + +UMVX (0\&:09) (0\&:37) 15\&.5 (0\&:38) (0\&:20) 2\&.06 (0\&:09) 2\&.98 (0\&:17) 10\&.98 (0\&:16) 95\&.61 (1\&:49) 4\&.93 (0\&:16) 172.4 208.3 + +VMVX n/a n/a n/a n/a (0\&:17) 3\&.44 (0\&:11) 4\&.31 (0\&:15) 9\&.32 (0\&:12) 74\&.72 (1\&:26) 10\&.83 (0\&:35) 192.3 294.1 + +VMVXM (0\&:17) (2\&:16) 27\&.58 (0\&:39) (0\&:16) 3\&.51 (0\&:07) 4\&.31 (0\&:10) 9\&.31 (0\&:11) 74\&.54 (1\&:21) 10\&.81 (0\&:27) 312.5 500.0 + +V780 n/a n/a n/a n/a (0\&:16) 3\&.38 (0\&:08) 4\&.00 (0\&:11) 6\&.88 (0\&:08) 45\&.47 (0\&:53) 7\&.71 (0\&:12) 227.3 416.7 + +V780S (0\&:15) (2\&:09) 26\&.10 (0\&:31) (0\&:19) 3\&.57 (0\&:10) 4\&.22 (0\&:17) 6\&.78 (0\&:10) 45\&.11 (0\&:57) 7\&.83 (0\&:14) 166.7 263.2 + +V8600 (0\&:08) (1\&:05) 8\&.59 (0\&:17) (0\&:09) 1\&.56 (0\&:05) 1\&.28 (0\&:07) 2\&.09 (0\&:04) 13\&.54 (0\&:32) 2\&.58 (0\&:06) 294.1 625.0 + +MV10 (0\&:14) (0\&:29) 6\&.4 (0\&:25) (0\&:09) 1\&.5 (0\&:06) 1\&.6 (0\&:08) 4\&.8 (0\&:07) 39\&.3 (0\&:47) 2\&.9 (0\&:06) 89.3 200.0 + +MV8 (0\&:28) (2\&:17) 13.13 (0\&:57) (0\&:16) 2\&.85 (0\&:12) 3\&.07 (0\&:17) 9\&.87 (0\&:13) 77\&.68 (1\&:31) 5\&.69 (0\&:12) 31\&.1 200\&.0 +.TE +.sp +.LP +\fBKEY:\fR +.TS +lB lw(8.0i). +ISI T{ +Integrated Solutions with 16-Mhz 68020 and 16-Mhz 68881 fp_coprocessor; UNIX +4.2BSD; 8Mb memory; Greenhills compiler +T} +SUN3 T{ +SUN 3/160C with 68881 fp_chip; SUN UNIX 3.3; 8Mb memory; Eagle +disk with 380Mb +T} +SUN3+ T{ +SUN 3/180C with 68881 fp_chip + FPA; SUN UNIX 3.2; 8Mb memory; 380Mb Eagle disk +T} +U750 VAX 11/750+FPA; UNIX 4.3BSD; 8Mb memory; RA81 disk +V750 VAX 11/750+FPA; VMS V4.5; 7.25 Mb memory; RA81/clustered disks +UMVX VAXSTATION II/GPX; ULTRIX 1.2; 5Mb memory; 150 Mb RD54 disk +VMVXM T{ +VAXSTATION II/GPX; MICROVMS V4.5; 5Mb memory; IRAF installed on 300MB +MAXSTOR disk, data files on this disk also +T} +VMVX T{ +VAXSTATION II/GPX; MICROVMS V4.5; 5Mb memory; IRAF on 300MB +MAXSTOR disk, data on 70Mb RD53 (84% full) +T} +V780 T{ +VAX 11/780+FPA; VMS V4.5; 16Mb memory; IRAF installed on an RA81, data on an +RM03 disk with 23 free Mb, Massbus +T} +V780S T{ +VAX 11/780+FPA; VMS V4.5; 16Mb memory; IRAF and data on an RA81 disk, Unibus +T} +V8600 VAX 8600; VMS V4.5; 28Mb memory; RA81/clustered disks +MV10 T{ +MV 10000; AOSVS 7.54; 24Mb memory; 2-600 Mb ARGUS and 2-600 Mb KISMET disks +T} +MV8 T{ +MV 8000 at La Serena; 5Mb memory, 2 large DG disks, 2 small Winchesters, +disks nearly full and badly fragmented +T} +.TE diff --git a/pkg/bench/fortask.cl b/pkg/bench/fortask.cl new file mode 100644 index 00000000..586386e5 --- /dev/null +++ b/pkg/bench/fortask.cl @@ -0,0 +1,15 @@ +# FORTASK -- Execute a foreign task repeatedly. + +procedure fortask (nreps) + +int nreps { prompt = "number of repetitions" } +int i + +begin + time; print ("======= begin ========") + + for (i=nreps; i > 0; i-=1) + !rmbin + + print ("======= end ========"); time +end diff --git a/pkg/bench/mkpkg b/pkg/bench/mkpkg new file mode 100644 index 00000000..d0ada370 --- /dev/null +++ b/pkg/bench/mkpkg @@ -0,0 +1,5 @@ +# Make the bench package. + +$omake x_bench.x +$link x_bench.o +$exit diff --git a/pkg/bench/plots.cl b/pkg/bench/plots.cl new file mode 100644 index 00000000..dc92ae4b --- /dev/null +++ b/pkg/bench/plots.cl @@ -0,0 +1,20 @@ +# PLOTS -- Measure the time required to make a number of row plots of an image. + +procedure plots (image, nlines) + +string image { prompt = "image to be plotted" } +int nlines { prompt = "number of line plots to be made" } + +string imname +int nleft + +begin + cache ("prow") + imname = image + time(); print ("======== start ========") + + for (nleft=nlines; nleft > 0; nleft-=1) + $prow (imname, 50, >G "dev$null") + + print ("======== end ========"); time() +end diff --git a/pkg/bench/subproc.cl b/pkg/bench/subproc.cl new file mode 100644 index 00000000..d1371484 --- /dev/null +++ b/pkg/bench/subproc.cl @@ -0,0 +1,18 @@ +# SUBPROC -- Benchmark the process control facilities. + +procedure subproc (nreps) + +int nreps { prompt = "number of repetitions" } +int i + +begin + time; print ("======= begin ========") + + for (i=nreps; i > 0; i-=1) { + prcache ("imheader") + flprcache ("imheader") + time() + } + + print ("======= end ========"); time +end diff --git a/pkg/bench/x_bench.x b/pkg/bench/x_bench.x new file mode 100644 index 00000000..f6d6e3df --- /dev/null +++ b/pkg/bench/x_bench.x @@ -0,0 +1,229 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# BENCH -- IRAF benchmark tasks. + +task ptime = t_ptime, + getpar = t_getpar, + wipc = t_wipc, + rbin = t_rbin, + wbin = t_wbin, + rrbin = t_rrbin, + rtext = t_rtext, + wtext = t_wtext + +define SZ_RBBUF 16384 +define SZ_BBUF 4096 +define SZ_TBUF 64 + + +# PTIME -- Print the current clock time. This is essentially a no-op task, +# used to test process connect/disconnect, IPC, and task startup/shutdown +# overhead. + +procedure t_ptime() + +char tbuf[SZ_TIME] +long clktime() + +begin + call cnvtime (clktime (long(0)), tbuf, SZ_TIME) + call printf ("%s\n") + call pargstr (tbuf) +end + + +# GETPAR -- Get a parameter from the CL repeatedly. Used to test the IPC +# turnaround time. + +procedure t_getpar() + +int niter, i +char paramval[SZ_FNAME] +int clgeti() + +begin + niter = clgeti ("niter") + do i = 1, niter + call clgstr ("cl.version", paramval, SZ_FNAME) +end + + +# WIPC -- Write to IPC (tests IPC bandwidth). + +procedure t_wipc() + +int fd, i +char bbuf[SZ_BBUF] +long n, filesize, clgetl() + +begin + fd = STDOUT + filesize = clgetl ("filesize") / SZB_CHAR + + do i = 1, SZ_BBUF + bbuf[i] = mod (i-1, 128) + 1 + + for (n=0; n < filesize; n = n + SZ_BBUF) + call write (fd, bbuf, SZ_BBUF) + + call eprintf ("wrote %d bytes\n") + call pargl (n * SZB_CHAR) +end + + +# RBIN -- Read from a binary file. + +procedure t_rbin() + +long totchars +char fname[SZ_FNAME] +char bbuf[SZ_BBUF] +int fd, open(), read() + +begin + call clgstr ("fname", fname, SZ_FNAME) + fd = open (fname, READ_ONLY, BINARY_FILE) + call fseti (fd, F_ADVICE, SEQUENTIAL) + totchars = 0 + + while (read (fd, bbuf, SZ_BBUF) == SZ_BBUF) + totchars = totchars + SZ_BBUF + + call close (fd) + call printf ("read %d bytes\n") + call pargl (totchars * SZB_CHAR) +end + + +# WBIN -- Write to a binary file. + +procedure t_wbin() + +char fname[SZ_FNAME] +char bbuf[SZ_BBUF] +int fd, i, open() +long n, filesize, clgetl() + +begin + call clgstr ("fname", fname, SZ_FNAME) + iferr (call delete (fname)) + ; + fd = open (fname, APPEND, BINARY_FILE) + call fseti (fd, F_ADVICE, SEQUENTIAL) + filesize = clgetl ("filesize") / SZB_CHAR + + do i = 1, SZ_BBUF + bbuf[i] = mod (i-1, 128) + 1 + + for (n=0; n < filesize; n = n + SZ_BBUF) + call write (fd, bbuf, SZ_BBUF) + + call close (fd) + call printf ("wrote %d bytes\n") + call pargl (n * SZB_CHAR) +end + + +# RTEXT -- Read from a text file. + +procedure t_rtext() + +long totchars +char fname[SZ_FNAME] +char tbuf[SZ_TBUF] +int fd, nchars, nlines +int open(), getline() + +begin + call clgstr ("fname", fname, SZ_FNAME) + fd = open (fname, READ_ONLY, TEXT_FILE) + totchars = 0 + nlines = 0 + + repeat { + nchars = getline (fd, tbuf) + if (nchars > 0) { + totchars = totchars + nchars + nlines = nlines + 1 + } + } until (nchars == EOF) + + call close (fd) + call printf ("read %d chars, %d lines\n") + call pargl (totchars) + call pargi (nlines) +end + + +# WTEXT -- Write to a text file. + +procedure t_wtext() + +char fname[SZ_FNAME] +char tbuf[SZ_TBUF] +int fd, op, open() +long n, nlines, filesize, clgetl() + +begin + call clgstr ("fname", fname, SZ_FNAME) + iferr (call delete (fname)) + ; + fd = open (fname, APPEND, TEXT_FILE) + filesize = clgetl ("filesize") + nlines = 0 + + for (op=1; op < SZ_TBUF; op=op+1) + tbuf[op] = '.' + + tbuf[op] = '\n' + op = op + 1 + tbuf[op] = EOS + + for (n=0; n < filesize; n = n + SZ_TBUF) { + call putline (fd, tbuf) + nlines = nlines + 1 + } + + call close (fd) + call printf ("wrote %d chars, %d lines\n") + call pargl (n) + call pargi (nlines) +end + + +# RRBIN -- Raw (unbuffered) read from a binary file. + +procedure t_rrbin() + +char fname[SZ_FNAME] +char bbuf[SZ_RBBUF] +long totchars, offset, buflen +int fd, chan, status +int open(), fstati() + +begin + call clgstr ("fname", fname, SZ_FNAME) + fd = open (fname, READ_ONLY, BINARY_FILE) + chan = fstati (fd, F_CHANNEL) + + buflen = SZ_RBBUF * SZB_CHAR + totchars = 0 + offset = 1 + status = 0 + + repeat { + totchars = totchars + (status / SZB_CHAR) + call zardbf (chan, bbuf, buflen, offset) + offset = offset + buflen + call zawtbf (chan, status) + } until (status <= 0) + + call close (fd) + call printf ("read %d bytes\n") + call pargl (totchars * SZB_CHAR) +end diff --git a/pkg/bench/xctest/README b/pkg/bench/xctest/README new file mode 100644 index 00000000..724ec929 --- /dev/null +++ b/pkg/bench/xctest/README @@ -0,0 +1,2 @@ +This directory is an example of a small IRAF package, used to benchmark the +time required to compile and link a small package. diff --git a/pkg/bench/xctest/columns.x b/pkg/bench/xctest/columns.x new file mode 100644 index 00000000..ee52abc5 --- /dev/null +++ b/pkg/bench/xctest/columns.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define MAX_FILES 12 + +.help columns +.nf___________________________________________________________________ +COLUMNS -- convert a multicolumn file into a multifile column. + One file `sdastemp.n' is produced with each column in a + Separate file. + +usage: COLUMNS number_of_columns File_name +.endhelp______________________________________________________________ + + +# COLUMNS.X -- SDAS support utility +# +# This routine allows SDAS to treat multicolumn tables +# as simple CL lists. Each column in the table is referenced in +# SDAS by a different parameter, pointing in the .par file to +# a different list. This routine is a preprocessor which takes +# a multicolumn file and generates a multifile column. +# +# To allow for column headers in the multicolumn file, +# any line which begins with a `#' will be ignored. +# All data is transferred as text. + +procedure t_columns() + +char fname[SZ_FNAME], outfile[SZ_FNAME], outroot[SZ_FNAME] +char line[SZ_LINE], word[SZ_LINE], filenum[SZ_FNAME] +int numcols, infile +int outnum[MAX_FILES] +int nchar, nfile, ip +int clgeti(), open(), getline(), itoc(), ctowrd() +errchk open, getline + +begin + + # Get the number of columns and the input file name + call clgstr ("filename", fname, SZ_FNAME) + numcols = clgeti ("numcols") + call clgstr ("outroot", outroot, SZ_FNAME) + + # Open all the files + infile = open (fname, READ_ONLY, TEXT_FILE) + for (nfile=1; nfile <= numcols; nfile=nfile+1) { + nchar = itoc (nfile, filenum, 2) + call strcpy ( outroot, outfile, SZ_FNAME) + call strcat ( filenum, outfile, SZ_FNAME) + outnum[nfile] = open (outfile, NEW_FILE, TEXT_FILE) + } + + # Separate each line of the input file + while (getline(infile, line) != EOF) { + if ((line[1] != '#') && (line[1] != '\n')) { + ip = 1 + for (nfile=1; nfile <= numcols; nfile=nfile+1) { + nchar = ctowrd (line, ip, word, SZ_LINE) + call strcat ('\n',word, SZ_LINE) + call putline (outnum[nfile], word) + } + } + } + + # close the files + call close(infile) + for (nfile=1; nfile <= numcols; nfile=nfile+1) { + call close(outnum[nfile]) + } +end diff --git a/pkg/bench/xctest/lintran.x b/pkg/bench/xctest/lintran.x new file mode 100644 index 00000000..fe0ffdbc --- /dev/null +++ b/pkg/bench/xctest/lintran.x @@ -0,0 +1,370 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops +define LEN_TR 9 # Length of structure TR + +# The TR transformation descriptor structure. + +define X1 Memr[P2R($1)] # Input origin +define Y1 Memr[P2R($1+1)] +define XSCALE Memr[P2R($1+2)] # Scale factors +define YSCALE Memr[P2R($1+3)] +define THETA Memr[P2R($1+4)] # Rotation angle +define X2 Memr[P2R($1+5)] # Output origin +define Y2 Memr[P2R($1+6)] +define COS_THETA Memr[P2R($1+7)] +define SIN_THETA Memr[P2R($1+8)] + + +# LINTRAN -- Performs a linear translation on each element of the +# input list, producing a transformed list as output. + +procedure t_lintran() + +char in_fname[SZ_FNAME] +int list +pointer sp, tr +int xfield, yfield, min_sigdigits + +int clgeti(), clpopni(), clgfil() + +begin + # Allocate memory for transformation parameters structure + call smark (sp) + call salloc (tr, LEN_TR, TY_STRUCT) + + # Call procedure to get parameters and fill structure + call lt_initialize_transform (tr) + + # Get field numbers from cl + xfield = clgeti ("xfield") + yfield = clgeti ("yfield") + min_sigdigits = clgeti("min_sigdigits") + + # Open template of input files + list = clpopni ("files") + + # While input list is not depleted, open file and transform list + while (clgfil (list, in_fname, SZ_FNAME) != EOF) + call lt_transform_file (in_fname, xfield, yfield, min_sigdigits, tr) + + # Close template + call clpcls (list) + call sfree (sp) +end + + +# LT_INITIALIZE_TRANSFORM -- gets parameter values relevant to the +# transformation from the cl. List entries will be transformed +# in procedure lt_transform. Scaling is performed +# first, followed by translation and then rotation. + +procedure lt_initialize_transform (tr) + +pointer tr + +bool clgetb() +real clgetr() + +begin + # Get parameters from cl + X1(tr) = clgetr ("x1") # (x1,y1) = crnt origin + Y1(tr) = clgetr ("y1") + XSCALE(tr) = clgetr ("xscale") + YSCALE(tr) = clgetr ("yscale") + THETA(tr) = clgetr ("angle") + if (! clgetb ("radians")) + THETA(tr) = THETA(tr) / 57.29577951 + X2(tr) = clgetr ("x2") # (x2,y2) = new origin + Y2(tr) = clgetr ("y2") + + # The following terms are constant for a given transformation. + # They are calculated once and saved in the structure. + + COS_THETA(tr) = cos (THETA(tr)) + SIN_THETA(tr) = sin (THETA(tr)) +end + + +# LT_TRANSFORM_FILE -- This procedure is called once for each file +# in the input list. For each line in the input file that isn't +# blank or comment, the line is transformed. Blank and comment +# lines are output unaltered. + +procedure lt_transform_file (in_fname, xfield, yfield, min_sigdigits, tr) + +char in_fname[ARB] +int xfield, yfield +pointer tr + +char outbuf[SZ_LINE] +int nfields, nchars, max_fields, in, nline +int nsdig_x, nsdig_y, offset, min_sigdigits +pointer sp, field_pos, linebuf, inbuf, ip +double x, y, xt, yt +int getline(), lt_get_num(), open() + +begin + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + + max_fields = MAX_FIELDS + + # Open input file + in = open (in_fname, READ_ONLY, TEXT_FILE) + + for (nline=1; getline (in, Memc[inbuf]) != EOF; nline = nline + 1) { + for (ip=inbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '#') { + # Pass comment lines on to the output unchanged. + call putline (STDOUT, Memc[inbuf]) + next + } else if (Memc[ip] == '\n' || Memc[ip] == EOS) { + # Blank lines too. + call putline (STDOUT, Memc[inbuf]) + next + } + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE) + call lt_find_fields (Memc[linebuf], Memi[field_pos], + max_fields, nfields) + + if (xfield > nfields || yfield > nfields) { + call eprintf ("Not enough fields in file '%s', line %d\n") + call pargstr (in_fname) + call pargi (nline) + call putline (STDOUT, Memc[linebuf]) + next + } + + offset = Memi[field_pos + xfield-1] + nchars = lt_get_num (Memc[linebuf+offset-1], x, nsdig_x) + if (nchars == 0) { + call eprintf ("Bad x value in file '%s' at line %d:\n") + call pargstr (in_fname) + call pargi (nline) + call putline (STDOUT, Memc[linebuf]) + next + } + + offset = Memi[field_pos + yfield-1] + nchars = lt_get_num (Memc[linebuf+offset-1], y, nsdig_y) + if (nchars == 0) { + call eprintf ("Bad y value in file '%s' at line %d:\n") + call pargstr (in_fname) + call pargi (nline) + call putline (STDOUT, Memc[linebuf]) + next + } + + call lt_transform (x, y, xt, yt, tr) + + call lt_pack_line (Memc[linebuf], outbuf, SZ_LINE, Memi[field_pos], + nfields, xfield, yfield, xt, yt, nsdig_x, nsdig_y, min_sigdigits) + + call putline (STDOUT, outbuf) + } + + call sfree (sp) + call close (in) +end + + +# LT_FIND_FIELDS -- This procedure finds the starting column for each field +# in the input line. These column numbers are returned in the array +# field_pos; the number of fields is also returned. + +procedure lt_find_fields (linebuf, field_pos, max_fields, nfields) + +char linebuf[SZ_LINE] +int field_pos[max_fields],max_fields, nfields +bool in_field +int ip, field_num + +begin + field_num = 1 + field_pos[1] = 1 + in_field = false + + for (ip=1; linebuf[ip] != '\n' && linebuf[ip] != EOS; ip=ip+1) { + if (! IS_WHITE(linebuf[ip])) + in_field = true + else if (in_field) { + in_field = false + field_num = field_num + 1 + field_pos[field_num] = ip + } + } + + field_pos[field_num+1] = ip + nfields = field_num +end + + +# LT_GET_NUM -- The field entry is converted from character to double +# in preparation for the transformation. The number of significant +# digits is counted and returned as an argument; the number of chars in +# the number is returned as the function value. + +int procedure lt_get_num (linebuf, dval, nsdig) + +char linebuf[SZ_LINE] +int nsdig +double dval +char ch +int nchar, ip + +int gctod() + +begin + ip = 1 + nsdig = 0 + nchar = gctod (linebuf, ip, dval) + if (nchar == 0 || IS_INDEFD (dval)) + return (nchar) + + # Skip leading white space. + ip = 1 + repeat { + ch = linebuf[ip] + if (! IS_WHITE(ch)) + break + ip = ip + 1 + } + + # Count signifigant digits + for (; ! IS_WHITE(ch) && ch != '\n' && ch != EOS; ch=linebuf[ip]) { + if (IS_DIGIT (ch)) + nsdig = nsdig + 1 + ip = ip + 1 + } + return (nchar) +end + + +# LT_TRANSFORM -- The linear transformation is performed in this procedure. +# First the coordinates are scaled, then rotated and translated. The +# transformed coordinates are returned. + +procedure lt_transform (x, y, xt, yt, tr) + +double x, y, xt, yt +pointer tr +double xtemp, ytemp + +begin + # Subtract off current origin: + if (IS_INDEFD (x)) + xt = INDEFD + else { + xt = x - X1(tr) + } + if (IS_INDEFD (y)) + yt = INDEFD + else { + yt = y - Y1(tr) + } + + # Scale and rotate coordinates: + if (THETA(tr) == 0) { + if (!IS_INDEFD (xt)) + xt = xt * XSCALE(tr) + X2(tr) + if (!IS_INDEFD (yt)) + yt = yt * YSCALE(tr) + Y2(tr) + return + + } else if (IS_INDEFD(xt) || IS_INDEFD(yt)) { + # Non-zero angle and either coordinate indefinite results in + # both transformed coordinates = INDEFD + xt = INDEFD + yt = INDEFD + return + } + + # Rotation for non-zero angle and both coordinates defined + xtemp = xt * XSCALE(tr) + ytemp = yt * YSCALE(tr) + + xt = xtemp * COS_THETA(tr) - ytemp * SIN_THETA(tr) + yt = xtemp * SIN_THETA(tr) + ytemp * COS_THETA(tr) + + # Now shift the rotated coordinates + xt = xt + X2(tr) + yt = yt + Y2(tr) +end + + +# LT_PACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure lt_pack_line (inbuf, outbuf, maxch, field_pos, nfields, + xfield, yfield, xt, yt, nsdig_x, nsdig_y, min_sigdigits) + +char inbuf[ARB], outbuf[maxch] +int maxch, field_pos[ARB], nfields, xfield, yfield, nsdig_x, nsdig_y +int min_sigdigits +double xt, yt + +char field[SZ_LINE] +int num_field, width, op + +int gstrcpy() + +begin + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + if (num_field == xfield) { + call lt_format_field (xt, field, maxch, nsdig_x, width, + min_sigdigits) + } else if (num_field == yfield) { + call lt_format_field (yt, field, maxch, nsdig_y, width, + min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], field, width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (field[1])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (field, outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS +end + + +# LT_FORMAT_FIELD -- A transformed coordinate is written into a string +# buffer. The output field is of (at least) the same width and significance +# as the input list entry. + +procedure lt_format_field (dval, wordbuf, maxch, nsdig, width, min_sigdigits) + +char wordbuf[maxch] +int width, nsdig, maxch, min_sigdigits +double dval + +begin + call sprintf (wordbuf, maxch, "%*.*g") + call pargi (width) + call pargi (max (min_sigdigits, nsdig)) + call pargd (dval) +end diff --git a/pkg/bench/xctest/mkpkg b/pkg/bench/xctest/mkpkg new file mode 100644 index 00000000..87b4c792 --- /dev/null +++ b/pkg/bench/xctest/mkpkg @@ -0,0 +1,25 @@ +# Make the LISTS package + +$call relink +$exit + +relink: + $set LIBS = "-lxtools" + + $update libpkg.a + $omake x_lists.x + $link x_lists.o libpkg.a $(LIBS) + ; + +clean: + $delete libpkg.a x_lists.o x_lists.e + ; + +libpkg.a: + table.x + words.x + tokens.x + unique.x + lintran.x + columns.x + ; diff --git a/pkg/bench/xctest/table.x b/pkg/bench/xctest/table.x new file mode 100644 index 00000000..75e0a3e3 --- /dev/null +++ b/pkg/bench/xctest/table.x @@ -0,0 +1,111 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# Read a list of strings from the standard input or a list of files and +# assemble them into a nicely formatted table. If reading from multiple +# input files, make a separate table for each. There is no fixed limit +# to the size of the table which can be formatted. The table is not +# sorted; this should be done as a separate operation if desired. + +define INIT_STRBUF 512 +define STRBUF_INCREMENT 1024 +define INIT_MAXSTR 64 +define MAXSTR_INCREMENT 128 + + +procedure t_table() + +int list, first_col, last_col, ncols, maxstrlen +int fd, nextch, nstrings, maxch, sz_strbuf, max_strings, ip +pointer sp, strbuf, fname, stroff +int strlen(), fscan(), nscan(), clpopni() +int clgfil(), open(), envgeti(), clplen(), clgeti() + +begin + # Allocate buffers. The string buffer "strbuf", and associated list + # of offsets "stroff" will be reallocated later if they fill up. + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call malloc (strbuf, INIT_STRBUF, TY_CHAR) + call malloc (stroff, INIT_MAXSTR, TY_INT) + + + # Get various table formatting parameters from CL. + ncols = clgeti ("ncols") + first_col = clgeti ("first_col") + last_col = clgeti ("last_col") + + # Attempt to read the terminal x-dimension from the environment, + # if the user did not specify a valid "last_col". No good reason + # to abort if cannot find environment variable. + if (last_col == 0) + iferr (last_col = envgeti ("ttyncols")) + last_col = 80 + + # Set maximum string length to size of an output line if max length + # not given. + maxstrlen = clgeti ("maxstrlen") + if (maxstrlen == 0) + maxch = last_col - first_col + 1 + else + maxch = min (maxstrlen, last_col - first_col + 1) + + max_strings = INIT_MAXSTR + sz_strbuf = INIT_STRBUF + + + # Read the contents of each file into a big string buffer. Print a + # separate table for each file. + + list = clpopni ("input_files") + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + nextch = 1 + nstrings = 0 + + # If printing several tables, label each with the name of the file. + if (clplen (list) > 1) { + call printf ("\n==> %s <==\n") + call pargstr (Memc[fname]) + } + + while (fscan (fd) != EOF) { + call gargstr (Memc[strbuf+nextch-1], maxch) + # Ignore blank lines and faulty scans. + if (nscan() == 0) + next + for (ip=strbuf+nextch-1; IS_WHITE (Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '\n' || Memc[ip] == EOS) + next + + # Save one indexed string index for strtbl. + Memi[stroff+nstrings] = nextch + nextch = nextch + strlen (Memc[strbuf+nextch-1]) + 1 + + # Check buffers, make bigger if necessary. + if (nextch + maxch >= sz_strbuf) { + sz_strbuf = sz_strbuf + STRBUF_INCREMENT + call realloc (strbuf, sz_strbuf, TY_CHAR) + } + # Add space for more string offsets if too many strings. + nstrings = nstrings + 1 + if (nstrings > max_strings) { + max_strings = max_strings + MAXSTR_INCREMENT + call realloc (stroff, max_strings, TY_INT) + } + } + + # Print the table on the standard output. + call strtbl (STDOUT, Memc[strbuf], Memi[stroff], nstrings, + first_col, last_col, maxch, ncols) + } + + call clpcls (list) + call mfree (strbuf, TY_CHAR) + call mfree (stroff, TY_INT) + call sfree (sp) +end diff --git a/pkg/bench/xctest/tokens.x b/pkg/bench/xctest/tokens.x new file mode 100644 index 00000000..c8793748 --- /dev/null +++ b/pkg/bench/xctest/tokens.x @@ -0,0 +1,140 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help tokens +.nf ___________________________________________________________________________ +TOKENS -- Break the input up into a series of tokens. The makeup of the +various tokens is defined by the FMTIO primitive ctotok, which is not very +sophisticated, and does not claim to recognize the tokens for any particular +language (though it does reasonably well for most modern languages). Comments +can be deleted if desired, and newlines may be passed on to the output as +tokens. + +Comments are delimited by user specified strings. Only strings which are also +recognized by ctotok() as legal tokens may be used as comment delimiters. +If newline marks the end of a comment, the end_comment string should be given +as "eol". Examples of acceptable comment conventions are ("#", eol), +("/*", "*/"), ("{", "}"), and ("!", eol). Fortran style comments ("^{c}",eol) +can be stripped by filtering with match beforehand. + +Each token is passed to the output on a separate line. Multiple newline +tokens are compressed to a single token (a blank line). If newline is not +desired as an output token, it is considered whitespace and serves only to +delimit tokens. +.endhelp ______________________________________________________________________ + +define SZ_COMDELIMSTR 20 # Comment delimiter string. + +procedure t_tokens() + +bool ignore_comments, comment_delimiter_is_eol +bool in_comment, pass_newlines +char begin_comment[SZ_COMDELIMSTR], end_comment[SZ_COMDELIMSTR] +int fd, list, token, last_token, last_nscan +pointer sp, fname, tokbuf, outstr, ip, op + +bool streq(), clgetb() +int clpopni(), clgfil(), fscan(), nscan(), open(), ctocc() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (tokbuf, SZ_LINE, TY_CHAR) + call salloc (outstr, SZ_LINE, TY_CHAR) + + # If comments are to be ignored, get comment delimiters. + ignore_comments = clgetb ("ignore_comments") + if (ignore_comments) { + call clgstr ("begin_comment", begin_comment, SZ_COMDELIMSTR) + call clgstr ("end_comment", end_comment, SZ_COMDELIMSTR) + comment_delimiter_is_eol = streq (end_comment, "eol") + } else { + # Set begin_comment to null string to ensure that we never + # enter skip comment mode. This requires that we check for the + # EOS token before the begin_comment token below. + begin_comment[1] = EOS + } + + # Is newline a token? + pass_newlines = clgetb ("newlines") + + + # Merge all input files into a single stream of tokens on the standard + # output. + list = clpopni ("files") + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + last_token = NULL + + while (fscan (fd) != EOF) { + # Break input line into a stream of tokens. + repeat { + last_nscan = nscan() + call gargtok (token, Memc[tokbuf], SZ_LINE) + + # If "nscan" did not increment (actually impossible with + # gargtok) the line has been exhausted. + if (nscan() == last_nscan) + break + + # If busy ignoring a comment, check for delimiter. + if (in_comment) { + if (comment_delimiter_is_eol && + (token == TOK_NEWLINE || token == TOK_EOS)) { + in_comment = false + if (pass_newlines && last_token != TOK_NEWLINE) { + call printf ("\n") + last_token = TOK_NEWLINE + } + break + } else if (streq (Memc[tokbuf], end_comment)) { + in_comment = false + next + } else + next + } + + # If we get here, we are not processing a comment. + + if (token == TOK_NEWLINE) { + if (pass_newlines && last_token != TOK_NEWLINE) + call printf ("\n") + last_token = TOK_NEWLINE + break + + } else if (token == TOK_EOS) { + # EOS is not counted as a token (do not set last_token, + # do not generate any output). + break + + } else if (streq (Memc[tokbuf], begin_comment)) { + in_comment = true + # Do not change last_token, since comment token + # is to be ignored. + next + + } else if (token == TOK_STRING) { + # Convert control characters into printable + # sequences before printing string token. + op = outstr + for (ip=tokbuf; Memc[ip] != EOS; ip=ip+1) + op = op + ctocc (Memc[ip], Memc[op], SZ_LINE) + call printf ("\"%s\"\n") + call pargstr (Memc[outstr]) + + } else { # most tokens + call printf ("%s\n") + call pargstr (Memc[tokbuf]) + } + + last_token = token + } + } + call close (fd) + } + + call clpcls (list) + call sfree (sp) +end diff --git a/pkg/bench/xctest/unique.x b/pkg/bench/xctest/unique.x new file mode 100644 index 00000000..fcabfe00 --- /dev/null +++ b/pkg/bench/xctest/unique.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# UNIQUE -- Pass only unique lines from the (presumably sorted) standard +# input to the standard output. In other words, if a sequence of identical +# lines are found in the input, only one copy is passed to the output. + +procedure t_unique() + +int list, fd +pointer sp, fname, old_line, new_line, temp +bool streq() +int getline(), clpopni(), clgfil(), clplen(), open() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (old_line, SZ_LINE, TY_CHAR) + call salloc (new_line, SZ_LINE, TY_CHAR) + + list = clpopni ("files") + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + if (clplen (list) > 1) { + call printf ("\n\n==> %s <==\n") + call pargstr (Memc[fname]) + } + + Memc[old_line] = EOS + + while (getline (fd, Memc[new_line]) != EOF) { + if (streq (Memc[old_line], Memc[new_line])) + next + call putline (STDOUT, Memc[new_line]) + + # Swap buffers. + temp = old_line + old_line = new_line + new_line = temp + } + + call close (fd) + } + + call sfree (sp) +end diff --git a/pkg/bench/xctest/words.x b/pkg/bench/xctest/words.x new file mode 100644 index 00000000..42f4f97e --- /dev/null +++ b/pkg/bench/xctest/words.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# WORDS -- Break the input up into a series of words or strings. A word +# is a sequence of characters delimited by whitespace or newline. A string +# is delimited by single or double quotes, and may not span more than a single +# line. + +procedure t_words() + +int fd, list, last_nscan +pointer sp, fname, word +int clpopni(), clgfil(), fscan(), nscan(), open() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (word, SZ_LINE, TY_CHAR) + + list = clpopni ("files") + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + + # We do not know how may "words" there are on a line; get words + # until no more. + while (fscan (fd) != EOF) + repeat { + # When nscan() does not increment after a call to gargwrd(), + # we are all done. + last_nscan = nscan() + call gargwrd (Memc[word], SZ_LINE) + if (nscan() > last_nscan) { + call printf ("%s\n") + call pargstr (Memc[word]) + } else + break + } + + call close (fd) + } + + call clpcls (list) + call sfree (sp) +end diff --git a/pkg/bench/xctest/x_lists.x b/pkg/bench/xctest/x_lists.x new file mode 100644 index 00000000..01229e61 --- /dev/null +++ b/pkg/bench/xctest/x_lists.x @@ -0,0 +1,10 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Process configuration of the LISTS package. + +task table = t_table, + tokens = t_tokens, + unique = t_unique, + words = t_words, + lintran = t_lintran, + columns = t_columns diff --git a/pkg/cl/README b/pkg/cl/README new file mode 100644 index 00000000..3e0c476f --- /dev/null +++ b/pkg/cl/README @@ -0,0 +1,17 @@ +CL -- This directory contains the sources for the IRAF command language (CL). +The command language is implemented as a C program upon the IRAF VOS, using an +interface called LIBC (the C runtime library). LIBC is documented in the +source directory for the LIBC package, sys$libc. LIBC provides a C language +binding for the IRAF VOS, plus an implementation of the UNIX "stdio" library. + +To compile the CL, the libraries comprising the IRAF VOS must first be compiled +and installed in lib$. In addition the CL uses LIBC and two graphics +libraries, libstg.a (the STDGRAPH graphics kernel) and libcur.a (cursor mode, +for cursor type CL queries). A number of global include files are also +required and will be found in host$hlib/libc. The file must be +installed in a public directory where it can be found by the C compiler on your +system. + +Given these libraries the CL may be compiled and linked simply by typing +"mkpkg" in this directory. Typing "mkpkg update" will make the CL and +"install" the executable in the iraf$bin directory. diff --git a/pkg/cl/binop.c b/pkg/cl/binop.c new file mode 100644 index 00000000..e70e7794 --- /dev/null +++ b/pkg/cl/binop.c @@ -0,0 +1,664 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_xnames +#define import_math +#define import_ctype +#define import_stdio +#include + +#include "config.h" +#include "operand.h" +#include "errs.h" +#include "param.h" +#include "mem.h" +#include "task.h" +#include "proto.h" + + +/* + * BINOP.C -- Perform binary operations or expressions on two operands. + * + * Try to perform the arithmetic in native machine type, eg, don't do integer + * arithmetic by converting to floating and back. + */ + +/* Strint() looks for an integer on the left or right side of string s. + * If none found return NULL, else return pointer to the first + * character after it if looking on leftside or pointer to + * first of the digit characters if looking on right side. + * Make a few defines to make it easier to communicate with. + * Used by binop() to handle fancy string arithmetic. + * + * N.B.: The use of the '+' operator to increment the number part of + * a string has been restricted to strings of the form "abcde0123". + * Hence, the "leftside" logic in the following routine is no longer used. + */ + +#define LEFTSIDE 0 /* value of side */ +#define RIGHTSIDE 1 + +char * +strint ( + register char *s, + int side +) +{ + if (side == LEFTSIDE) { + while (isdigit (*s)) + s++; + } else { + char *sstart = s; + while (*s) + s++; + while (s > sstart && isdigit (s[-1])) + --s; + } + + return (*s == '\0' ? NULL : s); +} + + +/* BINOP -- Pop the top two operands from the stack and perform the binary + * operation whose code is in opcode. Push an operand with the proper result + * and (possibly promoted) type. + * If either is of type OT_STRING, result will be string and care must be + * taken not to pushop() the result to avoid clobbering them until done. + * Order of operands will be as stacked from left to right during parser + * recognition, eg, a-b pushes a, then b. + * Booleans are 0/1 arithmetically, or truestr/falsetr stringly. + * INDEF operands propagate through. We should never see an UNDEF operand. + * Call error() and do not return if internal error or undefined string + * operation. + */ +void +binop (int opcode) +{ + register int typ1, typ2; + struct operand o1, o2, result; + char res[2*SZ_LINE]; + char *o1sp; + double dresult=0.0; + int iresult=0, typecode=0; /* > 0 if real */ + long lval; + + o2 = popop(); /* operands will be on stack backwards */ + o1 = popop(); + typ1 = o1.o_type & OT_BASIC; + typ2 = o2.o_type & OT_BASIC; + + if (opindef (&o1) || opindef (&o2)) { + setopindef (&result); + goto pushresult; + } + + /* Verify that no illegal datatype conversions are implied. Arithmetic + * on booleans is illegal; arithmetic is legal on strings only in + * certain circumstances. + */ + if (typ1 == OT_BOOL || typ2 == OT_BOOL) + switch (opcode) { + case OP_ADD: + case OP_SUB: + case OP_MUL: + case OP_DIV: + case OP_POW: + cl_error (E_UERR, + "Illegal boolean operand in arithmetic expression"); + break; + + case OP_MAX: + case OP_MIN: + case OP_MOD: + case OP_RADIX: + case OP_ATAN2: + case OP_STRIDX: + case OP_STRLDX: + case OP_STRSTR: + case OP_STRLSTR: + cl_error (E_UERR, + "Intrinsic function called with illegal boolean argument"); + break; + + case OP_CONCAT: + ; /* bool -> string ok. */ + } + + if (typ1 == OT_REAL || typ2 == OT_REAL) + typecode = OT_REAL; + else + typecode = OT_INT; + + switch (opcode) { + case OP_ADD: + break; /* any datatype is ok here */ + case OP_CONCAT: + typecode = OT_STRING; + break; /* any datatype is ok here */ + case OP_RADIX: + if (typ2 != OT_INT) + cl_error (E_UERR, "Radix: second arg must be integer radix"); + typecode = OT_STRING; + break; + case OP_STRIDX: + case OP_STRLDX: + case OP_STRSTR: + case OP_STRLSTR: + if (typ1 != OT_STRING || typ2 != OT_STRING) + cl_error (E_UERR, + "stridx: both arguments must be of type string"); + typecode = OT_INT; + break; + case OP_SUB: + case OP_MUL: + case OP_DIV: + case OP_POW: + case OP_MAX: + case OP_MIN: + case OP_MOD: + case OP_ATAN2: + if (typ1 == OT_STRING || typ2 == OT_STRING) { + if (typ1 == OT_STRING) + cl_error (E_UERR, e_badstrop, o1.o_val.v_s); + else + cl_error (E_UERR, e_badstrop, o1.o_val.v_s); + } + break; + + default: + cl_error (E_IERR, e_badsw, opcode, "binop()"); + } + + /* The following code deals with operations which take string type + * operands or which produce a string result. + */ + if (typ1 == OT_STRING || typ2 == OT_STRING || typecode == OT_STRING) { + switch (opcode) { + case OP_ADD: + o1sp = o1.o_val.v_s; + + if (typ1 != OT_STRING) + cl_error (E_UERR, + "Illegal expression of the form 'number + string'"); + + if (typ2 == OT_STRING) { + strcpy (res, o1sp); + strcat (res, o2.o_val.v_s); + } else if (typ2 == OT_REAL) { + cl_error (E_UERR, e_strplusreal, o1sp); + + } else { /* typ2 is OT_INT */ + char *cp, format[MAX_DIGITS]; + int newnum; + + cp = strint (o1sp, RIGHTSIDE); + if (cp != NULL) { + /* Crack numeric string on rightside of string + * operand; add integer; reformat new string, + * trying to maintain number of digits in number. + */ + strncpy (res, o1sp, cp - o1sp); + newnum = atoi(cp) + (int)VALU(&o2); + sprintf (format, "%%0%dd", strlen (cp)); + sprintf ((char *)(res + (cp - o1sp)), + format, newnum); + if (newnum < 0) + cl_error (E_UERR, + "String + integer expression produces '%s' ", res); + + } else { + strcpy (res, o1sp); + for (cp=res; *cp; cp++) + ; + sprintf (cp, "%d", (int)VALU(&o2)); + } + } + break; + + case OP_CONCAT: + /* Convert operands to type string if necessary. + */ + { + char s2[SZ_LINE]; + + if (typ1 != OT_STRING) { + /* Save the o2 string since the operand cast here + * will overwrite it. + */ + if (typ2 == OT_STRING) + strcpy (s2, o2.o_val.v_s); + pushop (&o1); + opcast (OT_STRING); + o1 = popop(); + } + strcpy (res, o1.o_val.v_s); + + if (typ2 != OT_STRING) { + pushop (&o2); + opcast (OT_STRING); + o2 = popop(); + } + + /* If we had to convert the first operand, use the saved + * string. + */ + if (typ1 != OT_STRING && typ2 == OT_STRING) + strcat (res, s2); + else + strcat (res, o2.o_val.v_s); + + break; + } + + + case OP_RADIX: + if (typ1 == OT_STRING) { + if (sscanf (o1.o_val.v_s, "%ld", &lval) != 1) + cl_error (E_UERR, "Cannot coerce '%s' to integer", + o1.o_val.v_s); + } else if (typ1 == OT_REAL) { + lval = (long) o1.o_val.v_r; + } else + lval = (long) o1.o_val.v_i; + + sprintf (res, "%r*", o2.o_val.v_i, lval); + break; + + case OP_STRIDX: + /* index = stridx (chars, string); "chars" may be a string. + * Return index of first occurence of any of the "chars" + * in "string", or ZERO if none found. + */ + { + char *ip, *cp, ch; + + iresult = 0; + for (ip=o2.o_val.v_s; !iresult && (ch = *ip) != EOS; ip++) { + for (cp=o1.o_val.v_s; *cp != EOS; cp++) { + if (*cp == ch) { + iresult = (ip - o2.o_val.v_s + 1); + break; + } + } + } + } + + result.o_val.v_i = iresult; + result.o_type = OT_INT; + goto pushresult; + break; + + case OP_STRLDX: + /* index = strldx (chars, string); "chars" may be a string. + * Return index of last occurence of any of the "chars" + * in "string", or ZERO if none found. + */ + { + char *ip, *cp, ch; + int len; + + iresult = 0; + len = strlen (o2.o_val.v_s); + for (ip=&o2.o_val.v_s[len-1]; + !iresult && (ch = *ip) != EOS && ip >= o2.o_val.v_s; + ip--) { + for (cp=o1.o_val.v_s; *cp != EOS; cp++) { + if (*cp == ch) { + iresult = (ip - o2.o_val.v_s + 1); + break; + } + } + } + } + + result.o_val.v_i = iresult; + result.o_type = OT_INT; + goto pushresult; + break; + + case OP_STRSTR: + /* index = strstr (s1, s2); + * Return index of first occurance of the string 's1' in 's2', + * or ZERO if none found. + */ + { + char *ip, *cp, *fp, first_char, ch; + + first_char = o1.o_val.v_s[0]; + + /* Null patterns match any string. */ + if (first_char == NULL) { + result.o_val.v_i = 1; + result.o_type = OT_INT; + goto pushresult; + } else + iresult = 0; + + /* Search s2 for first_char, if found check for complete + * match of s1, else move on. + */ + for (ip=o2.o_val.v_s; !iresult && (ch = *ip) != EOS; ip++) { + if (ch == first_char) { + fp = ip; + cp = o1.o_val.v_s; + while (*cp != EOS && *cp == *ip) { + cp++; ip++; + } + if (*cp == EOS) { + iresult = (fp - o2.o_val.v_s + 1); + break; + } + } + } + } + + result.o_val.v_i = iresult; + result.o_type = OT_INT; + goto pushresult; + + case OP_STRLSTR: + /* index = strstr (s1, s2); + * Return index of last occurance of the string 's1' in 's2', + * or ZERO if none found. + */ + { + char *ip, *cp, *fp, first_char, ch; + int len; + + first_char = o1.o_val.v_s[0]; + + /* Null patterns match any string. */ + if (first_char == NULL) { + result.o_val.v_i = 1; + result.o_type = OT_INT; + goto pushresult; + } else + iresult = 0; + + /* Search s2 for first_char, if found check for complete + * match of s1, else move on. + */ + len = strlen (o2.o_val.v_s); + for (ip=&o2.o_val.v_s[len-1]; + !iresult && (ch = *ip) != EOS && ip >= o2.o_val.v_s; + ip--) { + if (ch == first_char) { + fp = ip; + cp = o1.o_val.v_s; + while (*cp != EOS && *cp == *ip) { + cp++; ip++; + } + if (*cp == EOS) { + iresult = (fp - o2.o_val.v_s + 1); + break; + } else + ip = fp; + } + } + } + + result.o_val.v_i = iresult; + result.o_type = OT_INT; + goto pushresult; + } + + /* Cannot "goto pushresult" because would lose res core */ + result.o_type = OT_STRING; + result.o_val.v_s = res; + pushop (&result); + return; + } + + + /* Hereafter, we only deal with operands of type int or real. + */ + if (typecode != OT_REAL) + typecode = 0; + + switch (opcode) { + case OP_ADD: + if (typecode) dresult = VALU(&o1) + VALU(&o2); + else iresult = o1.o_val.v_i + o2.o_val.v_i; + break; + + case OP_SUB: + if (typecode) dresult = VALU(&o1) - VALU(&o2); + else iresult = o1.o_val.v_i - o2.o_val.v_i; + break; + + case OP_MUL: + if (typecode) dresult = VALU(&o1) * VALU(&o2); + else iresult = o1.o_val.v_i * o2.o_val.v_i; + break; + + case OP_DIV: + if (typecode) { + if (VALU(&o2) == 0.0) + cl_error (E_UERR, e_fdivzero, opcode, "binop()"); + else + dresult = VALU(&o1) / VALU(&o2); + } else { + if (o2.o_val.v_i == 0) + cl_error (E_UERR, e_idivzero, opcode, "binop()"); + else + iresult = o1.o_val.v_i / o2.o_val.v_i; + } + break; + + case OP_POW: + { /* VMS & inconsistancy */ + double val1 = VALU(&o1),val2 = VALU(&o2); + double sign = 1; + + /* Exponentiation of negative numbers to real powers + * is not defined in general, so if we have coerced + * an integer exponent to real we change the mantissa to + * positive and deal with the sign separately. + */ + if ((o2.o_type == OT_INT) && (val1 < 0)) { + sign = (o2.o_val.v_i % 2) ? -1 : 1 ; + if (val1 < 0) + val1 = -val1; + } + + dresult = sign * pow (val1, val2); + if (!typecode) + iresult = dresult+0.5*sign; /* round */ + } + break; + + case OP_MAX: + if (typecode) { + /* ritchie compiler doesn't seem to allow ?: here. + * result = (VALU(&o1) > VALU(&o2)) ? o1 : o2; + */ + if (VALU(&o1) > VALU(&o2)) + result = o1; + else + result = o2; + } else { + if (o1.o_val.v_i > o2.o_val.v_i) + result = o1; + else + result = o2; + } + goto pushresult; + + case OP_MIN: + if (typecode) { + /* ritchie compiler doesn't seem to allow ?: here. + * result = (VALU(&o1) < VALU(&o2)) ? o1 : o2; + */ + if (VALU(&o1) < VALU(&o2)) + result = o1; + else + result = o2; + } else { + if (o1.o_val.v_i < o2.o_val.v_i) + result = o1; + else + result = o2; + } + goto pushresult; + + case OP_MOD: + if (typecode) { + double x1 = VALU(&o1), x2 = VALU(&o2); + dresult = x1 - ((int)(x1/x2))*x2; + } else + iresult = o1.o_val.v_i % o2.o_val.v_i; + break; + + case OP_ATAN2: + { /* VMS & inconsistancy. */ + double val1 = VALU(&o1), val2 = VALU(&o2); + dresult = atan2 (val1, val2); + } + typecode++; /* force real result */ + break; + + default: + cl_error (E_IERR, e_badsw, opcode, "binop()"); + } + + if (typecode) { + result.o_val.v_r = dresult; + result.o_type = OT_REAL; + } else { + result.o_val.v_i = iresult; + result.o_type = OT_INT; + } + +pushresult: + pushop (&result); +} + + +/* BINEXP -- pop top two operands and push result of applying operand. + * result o_type will be OT_BOOL and o_val.v_i as returned from relation. + * both or neither operand may be a string; cannot be mixed. + * order of operands will be as stacked from left to right during parser + * recognition, eg, a 0; + else + result.o_val.v_i = VALU(&o1) > VALU(&o2); + break; + + case OP_LE: + if (dostr) + result.o_val.v_i = (strres <= 0); + else + result.o_val.v_i = (VALU(&o1) <= VALU(&o2)); + break; + + case OP_GE: + if (dostr) + result.o_val.v_i = (strres >= 0); + else + result.o_val.v_i = (VALU(&o1) >= VALU(&o2)); + break; + + case OP_EQ: + if (opindef (&o1) || opindef (&o2)) + result.o_val.v_i = (opindef (&o1) == opindef (&o2)); + else { + if (dostr) + result.o_val.v_i = (strres == 0); + else + result.o_val.v_i = (VALU(&o1) == VALU(&o2)); + } + break; + + case OP_NE: + if (opindef (&o1) || opindef (&o2)) + result.o_val.v_i = (opindef (&o1) != opindef (&o2)); + else { + if (dostr) + result.o_val.v_i = (strres != 0); + else + result.o_val.v_i = (VALU(&o1) != VALU(&o2)); + } + break; + + case OP_OR: + if (dostr) + result.o_val.v_i = strlen (o1.o_val.v_s) || + strlen (o2.o_val.v_s); + else + result.o_val.v_i = (o1.o_val.v_i || o2.o_val.v_i); + break; + + case OP_AND: + if (dostr) + result.o_val.v_i = strlen (o1.o_val.v_s) && + strlen (o2.o_val.v_s); + else + result.o_val.v_i = (o1.o_val.v_i && o2.o_val.v_i); + break; + + default: + cl_error (E_IERR, e_badsw, opcode, "binexp()"); + + } + + result.o_type = OT_BOOL; + +pushresult: + pushop (&result); +} diff --git a/pkg/cl/bkg.c b/pkg/cl/bkg.c new file mode 100644 index 00000000..5ae1f0dd --- /dev/null +++ b/pkg/cl/bkg.c @@ -0,0 +1,647 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#define import_knames +#define import_xwhen +#define import_ctype +#include + +#include "config.h" +#include "clmodes.h" +#include "operand.h" +#include "clmodes.h" +#include "mem.h" +#include "errs.h" +#include "param.h" +#include "task.h" +#include "proto.h" + + +/* + * BKG -- All the functions relating to background ("&" asychronous) jobs. + * + * Here's how it works: yyparse() compiles code into the stack in the usual + * way, incrementing pc as it goes. If an '&' is seen, a snapshot of the + * dictionary, the stack, and all related pointers is written to a file + * immediately. The new code is discarded (by putting the pc back where it was) + * and yyparse() is called again. See the forever() loop in main. + * When started as a background cl, the snapshot file is read in and main + * jumps immediately to run() as though yyparse() had just finished compiling. + * Thus, background code is compiled in the parent but sent to the child cl + * to be executed. The t_flags T_BATCH bit is set in the new cl's currentask + * as well as firstask. The former is used by bkg_abort() to abort + * grandchildren. + * + * bkg_init () setup bkg job + * bkg_spawn (cmd) spawn bkg job + * bkg_wait (job) wait for termination + * bkg_kill (job) kill bkg job + * bkg_jobstatus (fp, job) print job status + * bool = bkg_jobactive (job) job is active + * bkg_update (pmsg) update bkg job status + * + * bkg_startup () called in bkg job to startup + * bkg_abort () called by bkg job on interrupt + * + * Job numbers start at 1 and count up to the maximum number of bkg jobs + * permitted. In all of the above commands, the function will be performed + * for a single job if job>0. If job=0 the function is applied to all jobs. + */ + +extern int cldebug; + +/* We need to pass the pipe file names along to the bkg cl because the name + * of the pipe file to use is determined AT PARSE TIME, not when the file + * gets opened. Without this, rmpipe() doesn't have the right names and + * dreg pipe files will be left around. + */ +extern int pipetable[]; /* pipe stack (pipecodes) */ +extern int nextpipe; /* pipe stack pointer (next index) */ +extern int dobkg; /* flag bkg execution */ + +extern memel cl_dictbuf[]; /* static dictionary area */ +extern long c_clktime(); +extern char *findexe(); + +#define BKGHDRSIZ (sizeof (struct bkgfilehdr)) +#define SZ_CMD 40 /* command in jobs table */ +#define SZ_BKCMD 80 /* command in bkg file */ +#define SZ_ENVDEF 1024 /* max size environment define */ +#define WAIT_PERIOD 5 /* bkg_wait wait interval */ +#define BKG_MAGIC 237 +#define SZ_BKGMSG 64 +#define CLDIR "iraf$pkg/cl/" + +char bkgmsg[SZ_BKGMSG+1]; /* passed to kernel */ +int lastjobno; /* last job slot used */ +int bkgno; /* job no. assigned by parent */ +int ppid; /* pid of parent CL */ + +/* Template for all the junk that goes into the background status file. + * Following this is the dictionary, then the stack. + * TODO: avoid copying binary images of the stack and dictionary + * areas to permit use of dynamic memory allocation. + */ +struct bkgfilehdr { + int b_magic; /* file identification */ + int b_bkgno; /* bkg job number of new CL */ + int b_ppid; /* pid of parent CL */ + char b_cmd[SZ_BKCMD]; /* command entered by user */ + int b_pipetable[MAXPIPES]; /* pipefile database */ + int b_nextpipe; /* more pipefile database */ + int b_szstack; /* size of stack area, bytes */ + int b_szdict; /* size of dictionary, bytes */ + memel *b_dict; /* ptr to start of dict */ + XINT b_topd, /* dict ptr */ + b_maxd, /* top of dict */ + b_pachead, /* head of package list */ + b_parhead, /* head of param list */ + b_pc, /* pointer to compiled metacode */ + b_topos, /* top of operand stack */ + b_basos, /* base of operand stack */ + b_topcs; /* top of control stack */ + struct task *b_firstask, /* first task struct */ + *b_currentask; /* current task struct */ + struct package *b_curpack; /* current package */ +}; + + +/* Job table. Associate the ordinal job number with the job number returned + * by the system. Record the command string which caused the bkg job to be + * submitted, for output with bkg_jobstatus(). + */ +struct _bkgjob { + int b_jobno; /* job no. assigned by system */ + short b_flags; /* job state flags */ + short b_exitcode; /* exit status of job */ + long b_clock; /* start time; elapsed time */ + char b_cmd[SZ_CMD+1]; /* command entered by user */ +} jobtable[NBKG]; + +#define J_RUNNING 01 /* job is running or queued */ +#define J_SERVICE 02 /* job needs service */ +#define J_KILLED 04 /* job was killed */ +#define busy(job) (jobtable[(job)-1].b_flags & J_RUNNING) + + +static void bkg_close (int job, int pmsg); + + +/* BKG_INIT -- Setup to execute a background job. Called by the lexical + * analyzer when the & is seen. Read in the bkg control string (anything + * following the & to end of line) and set the dobkg flag to flag background + * execution of the command block currently being parsed. + */ +void +bkg_init ( + char *bcs /* background control string */ +) +{ + strncpy (bkgmsg, bcs, SZ_BKGMSG); + dobkg++; +} + + +/* BKG_SPAWN -- Spawn a new background job. Called by main() when we have + * seen an '&'. + */ +void +bkg_spawn ( + char *cmd /* command entered by user to spawn job */ +) +{ + register struct _bkgjob *bk; + register int jobno, stat; + char clprocess[SZ_PATHNAME]; + char *bkgfile; + + /* Find first unused slot in a circular search. + */ + bkg_update (1); + jobno = (lastjobno == NBKG) ? 1 : lastjobno + 1; + while (jobno != lastjobno) { + if (!busy (jobno)) + break; + if (jobno++ >= NBKG) + jobno = 1; + } + if (jobno == lastjobno) + cl_error (E_UERR, "no more background job slots"); + + /* Write bkgfile. Delete any dreg bkg communication files. + */ + bkgfile = wbkgfile (jobno, cmd); + bkg_delfiles (jobno); + + /* Spawn bkg job. + */ + sprintf (clprocess, "%s%s", CLDIR, CLPROCESS); + intr_disable(); + jobtable[jobno-1].b_jobno = stat = + c_propdpr (findexe (firstask->t_curpack, clprocess), + bkgfile, bkgmsg); + + if (stat == NULL) { + c_delete (bkgfile); + intr_enable(); + cl_error (E_IERR, "cannot spawn background CL"); + } else { + bk = &jobtable[jobno-1]; + bk->b_flags = J_RUNNING; + bk->b_clock = c_clktime (0L); + strncpy (bk->b_cmd, cmd, SZ_CMD); + *(bk->b_cmd+SZ_CMD) = EOS; + intr_enable(); + } + + eprintf ("[%d]\n", lastjobno = jobno); + + /* Make a logfile entry, saying we started the background job. + */ + if (keeplog() && log_background()) { + char buf[SZ_LINE]; + sprintf (buf, "Start [%d]", jobno); + putlog (0, buf); + } +} + + +/* BKG_WAIT -- Wait for a background job to terminate. If job=0, wait for + * all bkg jobs to terminate. + */ +void +bkg_wait ( + register int job +) +{ + register int j; + int active_jobs; + + if (job < 0 || job > NBKG) + return; + + do { + bkg_update (1); + if (job && !busy(job)) + return; + else { + for (active_jobs=0, j=1; j <= NBKG; j++) + if (busy (j)) { + active_jobs++; + c_tsleep (WAIT_PERIOD); + break; + } + } + } while (active_jobs); +} + + +/* BKG_KILL -- Kill a background job. If job=0, kill all background jobs. + * If the job cannot be killed assume it is because it died unexpectedly. + */ +void +bkg_kill ( + int job +) +{ + register struct _bkgjob *bk; + register int j; + + bkg_update (1); + if (job < 0 || job > NBKG) + eprintf ("[%d] invalid job number\n", job); + else { + for (bk=jobtable, j=1; j <= NBKG; j++, bk++) { + if ((job == 0 && busy(j)) || job == j) { + if (!busy(j)) + eprintf ("[%d] not in use\n", j); + else if (c_prkill (bk->b_jobno) == ERR) + bkg_close (j, 2); + else { + bk->b_flags |= J_KILLED; + bkg_close (j, 2); + } + } + } + } +} + + +/* BKG_JOBSTATUS -- Print the status of one or more background jobs. + * format jobno, elapsed clock time, status, user command, e.g.: + * + * [1] 1:34 Running command_1 + * [2] 14:09 Stopped command_2 + * [3] 1:34 +Done command_3 + * [4] 1:34 Exit 23 command_4 + * + * A job will remain in the job table until another job is submitted which uses + * the same slot. + */ +void +bkg_jobstatus ( + FILE *fp, /* output file */ + int job /* job(s) */ +) +{ + register struct _bkgjob *bk; + register int j, n, ch; + register char *ip; + long seconds; + char *outstr; + + bkg_update (1); + for (bk=jobtable, j=1; j <= NBKG; j++, bk++) + if ((job == 0 && bk->b_jobno) || job == j) { + /* Print jobno. */ + fprintf (fp, " [%d] ", j); + + /* If the clock is still running b_clock contains the start + * time. If the job terminated it contains the elapsed time + * at job termination. + */ + if (busy(j)) + seconds = c_clktime (bk->b_clock); + else + seconds = bk->b_clock; + fprintf (fp, "%6.0m ", (float)seconds / 60.0); + fputc ((j == lastjobno) ? '+' : ' ', fp); + + /* Print job status. + */ + if (busy(j)) { + if (bk->b_flags & J_SERVICE) + outstr = "Stopped"; + else + outstr = "Running"; + } else if (bk->b_flags & J_KILLED) { + outstr = "Killed"; + } else if (bk->b_exitcode == OK) { + outstr = "Done"; + } else + sprintf (outstr, "Exit %d", bk->b_exitcode); + fprintf (fp, "%-10s", outstr); + + /* Finally, print user command followed by newline. + */ + n = c_envgeti ("ttyncols") - (8 + 8 + 10) - 1; + ip = bk->b_cmd; + while (--n >= 0 && (ch = *ip++) != EOS) + if (ch == '\n' || ch == '\t') + fputc (' ', fp); + else + fputc (ch, fp); + fputc ('\n', fp); + } +} + + +/* BKG_JOBACTIVE -- Determine if a background job is active, i.e., if the + * job is still running. It does not matter if the job is waiting for + * service. + */ +int +bkg_jobactive ( + int job +) +{ + bkg_update (1); + return (busy (job)); +} + + +/* BKG_UPDATE -- Update the jobtable. Examine each running process to see if + * has terminated or if it needs service. Set the appropriate bits in the + * state flag in the job table. When job termination is detected compute the + * elapsed time and leave it in the table, along with the exit status. If + * the notify option is off the done or wait message will not have been printed + * by the bkg job, so we output the message ourselves. + */ +void +bkg_update ( + int pmsg /* print event messages */ +) +{ + register struct _bkgjob *bk; + register int j; + + for (bk=jobtable, j=1; j <= NBKG; j++, bk++) { + if (busy(j)) { + if (c_prdone (bk->b_jobno)) { + bkg_close (j, pmsg); + } else if (bkg_wfservice (j)) { + if (pmsg && !notify() && !(bk->b_flags & J_SERVICE)) + eprintf ("[%d] stopped waiting for parameter input\n", + j); + bk->b_flags |= J_SERVICE; + } else + bk->b_flags &= ~J_SERVICE; + } + } +} + + +/* BKG_CLOSE -- Close a bkg job. Called after determining that the job has + * terminated. + */ +static void +bkg_close ( + int job, /* job ordinal */ + int pmsg /* print termination message */ +) +{ + register struct _bkgjob *bk = &jobtable[job-1]; + + bk->b_clock = c_clktime (bk->b_clock); + bk->b_exitcode = c_prcldpr (bk->b_jobno); + bk->b_flags &= ~(J_RUNNING|J_SERVICE); + + if (pmsg > 1 || (pmsg == 1 && !notify())) { + if (bk->b_exitcode != OK) { + eprintf ("[%d] exit %d\n", job, bk->b_exitcode); + } else { + eprintf ("[%d] done\n", job); + } + } + + /* Make a logfile entry, saying the background job ended. + */ + if (keeplog() && log_background()) { + char buf[SZ_LINE]; + sprintf (buf, "Stop [%d]", job); + putlog (0, buf); + } +} + + +/* BKG_WFSERVICE -- Determine if a bkg job is waiting for service (for the + * user to answer a query). + */ +int +bkg_wfservice ( + int job +) +{ + char bkg_query_file[SZ_PATHNAME]; + char query_response_file[SZ_PATHNAME]; + + get_bkgqfiles (job, c_getpid(), bkg_query_file, query_response_file); + return (c_access (bkg_query_file,0,0)); +} + + +/* BKG_DELFILES -- Called when a background job is spawned to make sure there + * are no dreg query service files lying about from a prior job which did not + * complete normally. + */ +void +bkg_delfiles ( + int job +) +{ + char bkg_query_file[SZ_PATHNAME]; + char query_response_file[SZ_PATHNAME]; + + get_bkgqfiles (job, c_getpid(), bkg_query_file, query_response_file); + c_delete (bkg_query_file); + c_delete (query_response_file); +} + + +/* BKG_STARTUP -- Called by a background CL during process startup. Read in + * the bkgfile and restore runtime context of the parent. + */ +void +bkg_startup ( + char *bkgfile +) +{ + rbkgfile (bkgfile); + setclmodes (firstask); + currentask->t_flags = firstask->t_flags = T_BATCH; +} + + +/* BKG_ABORT -- Called by onint() in main.c when we get interrupted while + * running as a bkg job. Kill any and all background CL's WE may have + * started, flush io, close any open pipe files, remove our job seq lock + * file, kill all tasks back to the one that started us as background and + * write a message on stderr. + */ +void +bkg_abort (void) +{ + register int job; + register struct task *tp; + + for (job=1; job <= NBKG; job++) + if (busy (job)) + bkg_kill (job); + + iofinish (currentask); + delpipes (0); + + tp = currentask; + while (!(tp->t_flags & T_BATCH)) { + killtask (tp); + tp = poptask(); + } + + fprintf (stderr, "\n[%d] killed\n", bkgno); +} + + +/* WBKGFILE -- Create a unique file, write and close the background file. + * Jobno is the job number the new cl is to think its running for. + * We don't use the global bkgno because that's OUR number, if we ourselves + * are background. + * Return pointer to the new name. + * No error return, but we may call error() and never return. + */ +char * +wbkgfile ( + int jobno, /* ordinal jobnumber of child */ + char *cmd /* command to be run in bkg */ +) +{ + static char *bkgwerr = "error writing background job file"; + static char bkgfile[SZ_PATHNAME]; + struct bkgfilehdr bh; + int n, show_redefs=NO; + FILE *fp; + + c_mktemp ("uparm$bkg", bkgfile, SZ_PATHNAME); + if ((fp = fopen (bkgfile, "wb")) == NULL) + cl_error (E_IERR, "unable to create background job file `%s'", + bkgfile); + + for (n=0; n < MAXPIPES; n++) + bh.b_pipetable[n] = pipetable[n]; + bh.b_nextpipe = nextpipe; + + strncpy (bh.b_cmd, cmd, SZ_BKCMD); + + bh.b_magic = BKG_MAGIC; + bh.b_bkgno = jobno; + bh.b_ppid = c_getpid(); + bh.b_szstack = STACKSIZ * BPI; + bh.b_szdict = topd * BPI; + bh.b_dict = dictionary; + bh.b_topd = topd; + bh.b_maxd = maxd; + bh.b_pachead = pachead; + bh.b_parhead = parhead; + bh.b_pc = pc; + bh.b_topos = topos; + bh.b_basos = basos; + bh.b_topcs = topcs; + bh.b_firstask = firstask; + bh.b_currentask = currentask; + bh.b_curpack = curpack; + + /* Write the header structure, followed by the stack area and the + * dictionary. + */ + if (fwrite ((char *)&bh, BKGHDRSIZ, 1, fp) == NULL) + cl_error (E_IERR|E_P, bkgwerr); + if (fwrite ((char *)stack, STACKSIZ, BPI, fp) == NULL) + cl_error (E_IERR|E_P, bkgwerr); + if (fwrite ((char *)dictionary, topd, BPI, fp) == NULL) + cl_error (E_IERR|E_P, bkgwerr); + + /* Write the environment as a sequence of SET statements in binary. + * Append a blank line as a terminator. + */ + c_envlist (fileno(fp), "set ", show_redefs); + fputs ("\n", fp); + + fclose (fp); + return (bkgfile); +} + + +/* RBKGFILE -- Read in and use background status file with given name. + * Do not remove the file -- the system does that upon process termination + * to signal the parent. If an error occurs do not call cl_error since + * we are called during process startup and error recovery is not yet + * possible (a memory fault will result). + */ +void +rbkgfile ( + char *bkgfile +) +{ + char set[SZ_ENVDEF]; + struct bkgfilehdr bh; + int n; + FILE *fp; + + if ((fp = fopen (bkgfile, "rb")) == NULL) { + fprintf (stderr, + "[B] ERROR: unable to open background job file `%s'\n", + bkgfile); + clexit(); + } + + if (fread ((char *)&bh, BKGHDRSIZ, 1, fp) == NULL) + goto abort_; + if (bh.b_magic != BKG_MAGIC) { + fprintf (stderr, "[B] ERROR: bad magic in bkgfile '%s'\n", bkgfile); + clexit(); + } + + /* The following assumes that the dictionary is statically allocated + * and cannot move around. + */ + if (bh.b_dict != cl_dictbuf) { + fprintf (stderr, + "BKG ERROR: new CL installed; logout and try again\n"); + clexit(); + } + + intr_disable(); + + for (n=0; n < MAXPIPES; n++) + pipetable[n] = bh.b_pipetable[n]; + nextpipe = bh.b_nextpipe; + + bkgno = bh.b_bkgno; + ppid = bh.b_ppid; + dictionary = bh.b_dict; + topd = bh.b_topd; + maxd = bh.b_maxd; + pachead = bh.b_pachead; + parhead = bh.b_parhead; + pc = bh.b_pc; + topos = bh.b_topos; + basos = bh.b_basos; + topcs = bh.b_topcs; + firstask = bh.b_firstask; + currentask = bh.b_currentask; + curpack = bh.b_curpack; + + /* Read stack area and dictionary. + */ + if (fread ((char *)stack, bh.b_szstack, 1, fp) == NULL) + goto abort_; + if (fread ((char *)dictionary, bh.b_szdict, 1, fp) == NULL) + goto abort_; + + /* Read and restore the environment. + */ + do { + if (fgets (set, SZ_ENVDEF, fp) == NULL) + goto abort_; + } while (c_envscan (set)); + + intr_enable(); + fclose (fp); + return; +abort_: + intr_enable(); + eprintf ("[B] ERROR: error reading background file\n"); + clexit(); +} diff --git a/pkg/cl/builtin.c b/pkg/cl/builtin.c new file mode 100644 index 00000000..1fa1ab9e --- /dev/null +++ b/pkg/cl/builtin.c @@ -0,0 +1,2397 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_fset +#define import_error +#define import_ctype +#define import_stdio +#define import_alloc +#define import_ttset +#include + +#include "config.h" +#include "clmodes.h" +#include "mem.h" +#include "operand.h" +#include "param.h" +#include "task.h" +#include "errs.h" +#include "proto.h" + + +/* + * BUILTIN -- This file contains the functions that perform the built-in + * commands of the cl, such as task, set, and package. also here is the + * code that adds these functions to the initial set of ltasks within the + * cl when it first starts up. + * Setbuiltins() contains a table of functions and their user names; add + * to this table when adding new builtin functions. + * The first comment line for each of the functions indicates the syntax of + * how it should be used by the user. The grammar allows the arguments + * to be optionally surrounded by parentheses. + * + * It must be emphasized that these builtin commands do, in fact, run as tasks + * just as any other task. the currentask pointer is pointing to this task. + * since most of the commands manipulate the dictionary and these changes were + * intended for the previous task (the one that did the command) the builtins + * must modify the topd value saved in the previous task so the effect stays + * when the builtin's task finishes; thus, the builtins do a kind of "keep". + * + * Further, when called, the dictionary contains the fake parameter file + * manufactured for the builtin, as pointed to by currentask->t_pfp, but topd + * and parhead have been put back the way they were before the command was + * started. Thus, if the builtin adds to the dictionary, it will overwrite its + * parameters. This is avoided by using pushxparams() which pushes the value + * and name fields of the parameters in a pfile as operands. The builtin may + * then access these fields of its parameters, by popping them off the stack, + * yet make dictionary additions. The number of parameters is given by + * the function nargs(). + */ + +extern int cldebug; +extern int cltrace; +extern int lastjobno; /* last background job spawned */ +extern int gologout; /* flag to execute() to cause logout */ +extern int logout_status; /* optional arg to logout() */ +extern char *findexe(); + +/* Device Allocation stuff (really should be in a separate package). + */ +#define SZ_DEVNAME 12 +#define MAX_ALLOCDEV 10 + +struct d_alloc { + short allocated; + char devname[SZ_DEVNAME+1]; +}; + +static int nallocdev = 0; /* Count of allocated devices */ +static int nlogouts = 0; /* Count of logout attempts */ +static struct d_alloc + allocdev[MAX_ALLOCDEV]; /* Save names of alloc devices */ + + +/* BYE -- Called by our parent as the regular "bye" directive when it is + * finished. All we need to do is pop the currentask. The normal handling + * of builtins does an oneof() which will perform the actions for our parent. + * See execnewtask() for builtins. + */ +void +clbye (void) +{ + currentask = poptask(); +} + + +/* LOGOUT -- Logout from a CL session. Ignore the first attempts if there + * are allocated devices, but if the user persists permit the logout with + * the devices still allocated. + */ +void +cllogout (void) +{ + register int n; + register struct d_alloc *dv; + register struct pfile *pfp; + struct operand o; + char owner[SZ_FNAME+1]; + + + /* Set logout status value */ + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) > 0) { + pushbparams (pfp->pf_pp); /* push so first popped is 1st param */ + popop(); /* discard the $n name */ + o = popop(); /* pop logout status number */ + + if ((o.o_type & OT_BASIC) == OT_STRING) { + eprintf ("Warning: logout status `%s' not a number\n", + o.o_val.v_s); + nlogouts++; + gologout = 1; /* LOGOUT on third attempt */ + return; + } + + pushop (&o); + opcast (OT_INT); + o = popop(); + logout_status = o.o_val.v_i; + } else + logout_status = 0; + + + /* Clean up any allocated devices. + */ + if (nallocdev > 0) { + /* Examine each apparently allocated device to see if it is in + * fact still allocated. + */ + for (n=0; n < MAX_ALLOCDEV; n++) { + dv = &allocdev[n]; + if (dv->allocated) + if (c_devowner(dv->devname,owner,SZ_FNAME) != DV_DEVALLOC) { + dv->allocated = NO; + --nallocdev; + } + } + + /* Always print message if devices are allocated. + */ + if (nallocdev) { + eprintf ("The following devices are still allocated:"); + for (n=0; n < MAX_ALLOCDEV; n++) + if (allocdev[n].allocated) + eprintf (" %s", allocdev[n].devname); + eprintf ("\n"); + } + + if (nallocdev <= 0 || nlogouts++ > 1) + gologout = 1; /* LOGOUT on third attempt */ + + } else + gologout = 1; /* LOGOUT */ +} + + +/* CLBYE -- Like cl(), but sets end of file on the current file. This is + * done by the simple expedient of reopening the currentasks t_in as the null + * file, to ensure that anything which reads from the stream will see EOF. + * The reopen is performed in exec.c. + */ +void +clclbye (void) +{ +} + + +/* CACHE ltask [, ltask...] + * read in and keep pfiles for given ltasks. since they are pre-loaded, + * used to avoid reading pfile for each invokation of tasks. since they + * will not be above the new topd when the task bye's, they won't get + * flushed out either unless an explicit UPDATE is done or until the task + * that called us bye's. + * we check that the pfile is not already loaded and do nothing if it is. + */ +void +clcache (void) +{ + register struct pfile *pfp; + char pfilename[SZ_PATHNAME]; + char **list, **next; + struct operand o; + int n, npfile; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) < 1) { + static int first_col=7, maxch=20, ncol=0; + int last_col; + + last_col = c_envgeti ("ttyncols"); + + /* List all currently loaded paramfiles. + */ + for (npfile=0, pfp = reference (pfile, parhead); pfp != NULL; + pfp = pfp->pf_npf) { + if (!(pfp->pf_flags & (PF_FAKE|PF_COPY))) + npfile++; + } + + list = next = (char **)memneed (npfile); + for (pfp = reference (pfile, parhead); pfp != NULL; + pfp = pfp->pf_npf) + if (!(pfp->pf_flags & (PF_FAKE|PF_COPY))) { + strcpy (pfilename, pfp->pf_ltp->lt_pkp->pk_name); + strcat (pfilename, "."); + strcat (pfilename, pfp->pf_ltp->lt_lname); + *next++ = comdstr (pfilename); + } + strsort (list, npfile); + strtable (newtask->t_stdout, list, npfile, first_col, last_col, + maxch, ncol); + + } else { + /* Add listed pfiles to the cache. + */ + pushbparams (pfp->pf_pp); + while (n--) { + popop(); /* discard fake name. */ + o = popop(); /* get ltask */ + pfilesrch (o.o_val.v_s); + } + + /* Retain the pfiles read in. */ + keep (prevtask); + } +} + + +/* CL_LOCATE -- Locate the named task in the package list. + */ +void +cl_locate ( + char *task_spec, + int first_only +) +{ + char buf[SZ_LINE]; + char *pkname, *ltname, *junk; + struct package *pkp; + int stat, found = 0; + + strcpy (buf, task_spec); + breakout (buf, &junk, &pkname, <name, &junk); + + if (pkname[0] != '\0') { /* explicit package named */ + if ((pkp = pacfind (pkname)) == NULL) + cl_error (E_UERR, e_pcknonexist, pkname); + if ((stat = (int) ltaskfind (pkp, ltname, 1)) == NULL) + oprintf ("%s'\n", pkname); + + } else { /* search all packages */ + pkp = reference (package, pachead); + stat = NULL; + + while (pkp != NULL) { + stat = (int) ltaskfind (pkp, ltname, 1); + if (stat == ERR) + cl_error (E_UERR, e_tambig, ltname); + else if (stat != NULL) { + oprintf ("%s", pkp->pk_name); + found++; + if (first_only == YES) + break; + oprintf (" "); + } + pkp = pkp->pk_npk; + } + } + + if (found == NULL) + oprintf ("%s: task not found.\n", task_spec); + else + oprintf ("\n"); +} + + +/* CLWHICH -- Locate the named task in the package list. + */ +void +clwhich (void) +{ + register struct pfile *pfp; + struct operand o; + int n; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) < 1) + cl_error (E_UERR, e_geonearg, "which"); + + pushbparams (pfp->pf_pp); + while (n--) { + popop(); /* discard fake name. */ + opcast (OT_STRING); + o = popop(); /* get ltask */ + + cl_locate (o.o_val.v_s, YES); + } +} + + + +/* CLWHEREIS -- Locate all occurances of named task in the package list. + */ +void +clwhereis (void) +{ + register struct pfile *pfp; + struct operand o; + int n; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) < 1) + cl_error (E_UERR, e_geonearg, "whereis"); + + pushbparams (pfp->pf_pp); + while (n--) { + popop(); /* discard fake name. */ + opcast (OT_STRING); + o = popop(); /* get ltask */ + + cl_locate (o.o_val.v_s, NO); + } +} + + +/* FLPRCACHE -- Flush the process cache. If no args, flush all but locked + * processes. If arg=0, flush all processes and override locks. If argn=N, + * flush process N. + */ +void +clflprcache (void) +{ + register struct pfile *pfp; + register int n, pid; + struct operand o; + struct ltask *ltp; + int break_locks = 1; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) <= 0) { + pr_dumpcache (0, !break_locks); + return; + } + + pushbparams (pfp->pf_pp); /* push so first popped is first param */ + while (--n >= 0) { + popop(); /* discard the $n name */ + o = popop(); /* pop proc name or number */ + + if ((o.o_type & OT_BASIC) == OT_STRING) { + ltp = ltasksrch ("", o.o_val.v_s); + if (ltp->lt_flags & (LT_SCRIPT|LT_BUILTIN|LT_FOREIGN|LT_PSET)) + pid = NULL; + else + pid = pr_pnametopid (findexe(ltp->lt_pkp, + ltp->lt_u.ltu_pname)); + if (pid == NULL) { + eprintf ("Warning: task `%s' not in cache\n", o.o_val.v_s); + continue; + } + } else { + pushop (&o); + opcast (OT_INT); + o = popop(); + pid = o.o_val.v_i; + } + + pr_dumpcache (pid, break_locks); + } +} + + +/* CLPRCACHE -- If no args list the contents of the process cache, else lock + * the named tasks into the cache, connecting the associated process if + * necessary. + */ +void +clprcache (void) +{ + register struct pfile *pfp; + register int n, pid; + struct operand o; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) <= 0) { + pr_listcache (currentask->t_stdout); + return; + } + + pushbparams (pfp->pf_pp); /* push so first popped is first param */ + while (--n >= 0) { + popop(); /* discard the $n name */ + o = popop(); + + if ((o.o_type & OT_BASIC) == OT_STRING) { + if ((pid = pr_cachetask (o.o_val.v_s)) == ERR) + continue; + } else { + pushop (&o); + opcast (OT_INT); + o = popop(); + pid = o.o_val.v_i; + } + + pr_lock (pid); + } +} + + +/* CLGFLUSH -- Flush any buffered graphics output. Output to stdplot is + * buffered to permit appending to a plot. We are called to flush this + * last plot to the plotter. + */ +void +clgflush (void) +{ + c_gflush (STDGRAPH); + c_gflush (STDIMAGE); + c_gflush (STDPLOT); +} + + +static char cd_curr[SZ_PATHNAME]; /* current directory */ +static char cd_prev[SZ_PATHNAME]; /* previous directory */ +static char cd_emsg[] = "Cannot change directory to `%s'"; + +/* CHDIR -- Change the current working directory. If the change is successful + * update the cwd of all child processes as well. + */ +void +clchdir (void) +{ + register struct pfile *pfp; + struct operand o; + char *dirname; + char *index(), *envget(); + + pfp = newtask->t_pfp; + if (nargs (pfp) <= 0) { + o.o_type = OT_STRING; + if ((o.o_val.v_s = envget ("home")) == NULL) + cl_error (E_UERR, "No home directory defined in environment"); + } else { + pushbparams (pfp->pf_pp); + popop(); /* discard the $1 */ + opcast (OT_STRING); + o = popop(); /* get directory spec */ + } + + /* Record the current directory the first time we are called. + */ + if (cd_curr[0] == EOS) + c_fpathname ("", cd_curr, SZ_PATHNAME); + + /* Attempt to change the directory. + */ + dirname = o.o_val.v_s; + if (o.o_type != OT_STRING) + cl_error (E_UERR, cd_emsg, "??"); + else if (c_fchdir (dirname) == ERR) + cl_error (E_UERR, cd_emsg, dirname); + + /* Update cwd in all connected child processes. */ + pr_chdir (0, dirname); + + /* Update current and previous directory names. */ + strcpy (cd_prev, cd_curr); + c_fpathname ("", cd_curr, SZ_PATHNAME); +} + + +/* BACK -- Return to the previous directory. + */ +void +clback (void) +{ + char dirname[SZ_PATHNAME]; + + if (cd_prev[0] == EOS) + cl_error (E_UERR, "no previous directory"); + else + strcpy (dirname, cd_prev); + + if (c_fchdir (dirname) == ERR) + cl_error (E_UERR, cd_emsg, dirname); + + /* Update cwd in all connected child processes. */ + pr_chdir (0, dirname); + + /* Update current and previous directory names. */ + strcpy (cd_prev, cd_curr); + strcpy (cd_curr, dirname); + + /* Since we are the source of the directory name, rather than the + * user, print new directory name to ensure that there are no + * surprises. + */ + oprintf ("%s\n", dirname); +} + + +/* ERROR -- error code, message + * Print message on our stderr and pop back to a terminal cl task + * by handling it just like any other abortive type error. + */ +void +clerror (void) +{ + register struct param *arg1, *arg2; + register struct pfile *pfp; + int errcode; /* NOT USED */ + char *errmsg; + + pfp = newtask->t_pfp; + if (nargs (pfp) != 2) + cl_error (E_IERR, e_twoargs, "error()"); + arg1 = pfp->pf_pp; + arg2 = arg1->p_np; + + if (arg1 && (arg1->p_valo.o_type & OT_BASIC) == OT_INT) + errcode = arg1->p_val.v_i; + else + errcode = 1; + if (arg2 && (arg2->p_valo.o_type & OT_BASIC) == OT_STRING) + errmsg = arg2->p_val.v_s; + else + errmsg = ""; + + /* Pop the ERROR task, i.e., us. + */ + currentask = poptask(); + + /* Log the error message if from a script or an executable. Also, + * tell the CL error handler that we've already logged the error, by + * setting the 'errlog' flag. + */ + if (keeplog() && log_errors()) + if (currentask->t_flags & T_SCRIPT || currentask->t_pid != -1) { + char buf[SZ_LINE]; + extern int errlog; /* see errs.c */ + + strcpy (buf, "ERROR: "); + strcat (buf, errmsg); + putlog (currentask, buf); + errlog = 1; + } + + /* ERROR terminates a task like BYE. Pop the task which issued + * the error statement, provided it was not the first task. + */ + iofinish (currentask); + if (currentask != firstask) + currentask = poptask(); + + /* Now abort. This will unwind us back to the last interactive + * task. Any external child processes will be interrupted. If + * a child process issued the ERROR it will not be interrupted, + * because we already popped it above. + */ + cl_error (E_UERR, "%s", errmsg); +} + + +/* ? and ?? help commands. + * see listhelp() and listallhelp() in gram.c. + * note that since these names, ? and ??, do not fall under the ident lex + * rule, they need a special entry in the lex rule tables. + */ +void +clhelp (void) +{ + register struct pfile *pfp; + register struct package *pkp; + struct operand o; + int n, nleft, show_invis=NO; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) <= 0) + listhelp (curpack, show_invis); + else { + pushbparams (pfp->pf_pp); + for (nleft=n; nleft > 0; nleft--) { + popop(); + o = popop(); + if ((o.o_type & OT_BASIC) != OT_STRING) + cl_error (E_UERR, "non-string argument"); + if (o.o_val.v_s[0] == CH_INVIS) { + show_invis = YES; + if (n == 1) + listhelp (curpack, show_invis); + } else if ((pkp = pacfind (o.o_val.v_s)) == NULL) { + eprintf ("Warning: package '%s' not found\n", o.o_val.v_s); + } else if ((XINT)pkp == ERR) { + cl_error (E_UERR, e_pckambig, o.o_val.v_s); + } else { + if (n > 1) + oprintf (" %s:\n", pkp->pk_name); + listhelp (pkp, show_invis); + } + } + } +} + +void +clallhelp (void) +{ + int show_invis = NO; + + listallhelp (show_invis); +} + + +/* CLHISTORY -- Print the command history. We keep the number of history + * blocks to print in static storage, starting with a default of 20. This + * number is "learned" if the user calls history with the max_history arg. + */ +void +clhistory (void) +{ + register struct pfile *pfp; + struct operand o; + static int default_max_history = 15; + int max_history; + + max_history = default_max_history; + pfp = newtask->t_pfp; + + if (nargs (pfp) > 0) { + pushbparams (pfp->pf_pp); + popop(); /* discard the $1 */ + o = popop(); /* get max records */ + if (o.o_type != OT_INT) + cl_error (E_UERR, + "'history' arg is max number of records to print"); + max_history = o.o_val.v_i; + + /* Negative valued argument does not permanently change the + * default. + */ + if (max_history >= 0) + default_max_history = max_history; + else + max_history = -max_history; + } + + show_history (newtask->t_stdout, max_history); +} + + +/* CLTRACE -- Enable or disable instruction tracing (d_trace). + */ +void +dotrace (void) +{ + register struct pfile *pfp; + struct operand o; + int value = !cltrace; + + pfp = newtask->t_pfp; + + if (nargs (pfp) > 0) { + pushbparams (pfp->pf_pp); + popop(); /* discard the $1 */ + o = popop(); + if (o.o_type != OT_INT) + cl_error (E_UERR, "trace arg should be an integer"); + value = o.o_val.v_i; + } + + d_trace (value); +} + + +/* CLEHISTORY -- Edit command history. (dummy - see history.c) + */ +void +clehistory (void) +{ +} + + +/* CLSERVICE -- Service a query from a task in the background. The argument + * is the job number, default [1]. + */ +void +clservice (void) +{ + register struct pfile *pfp; + struct operand o; + int bkgjob; + + pfp = newtask->t_pfp; + if (nargs (pfp) < 1) + bkgjob = lastjobno; + else { + pushbparams (pfp->pf_pp); + popop(); /* discard the $1 */ + o = popop(); /* get max records */ + if (o.o_type != OT_INT) + cl_error (E_UERR, + "'service' arg is ordinal of bkg job to be serviced"); + bkgjob = o.o_val.v_i; + } + + service_bkgquery (bkgjob); +} + + +/* keep + * this command is used when changes to the dictionary, as with task + * or package directives for example, are to be saved after the task that + * issues the "keep" dies. since the keep command itself is handled as a + * task, this means the t_topd value saved two levels above the current + * task has to be modified. + * control stack grows downward so previous tasks are higher than currentask. + * because it was the very first task, it makes no sense for the initial + * interactive cl to do a keep. + */ +void +clkeep (void) +{ + register struct task *tp, *root_task; + + if (nargs (newtask->t_pfp) > 0) + cl_error (E_UERR, "`keep' command has no arguments"); + else if (prevtask == firstask) + return; + + /* If reading from the standard input, keep only the context of our + * caller. + */ + if (prevtask->t_in == firstask->t_in) { + keep (next_task(prevtask)); + return; + } + + /* Find the earliest task on the control stack which is reading from + * the same command input stream (script file) as our caller, and + * keep the context of all tasks from that point up to the present. + */ + for (tp=prevtask; tp != firstask; tp = next_task(tp)) { + if (tp->t_in == prevtask->t_in) + root_task = tp; + } + + for (tp=prevtask; tp != firstask; tp = next_task(tp)) { + keep (next_task(tp)); + if (tp == root_task) + break; + } +} + + +/* kill job [, job] + * zap background jobs, as defined by their one-indexed "job number". + * job zero is a special case that means kill all jobs. + * see bkg.c for more discussion and bkgkill(). + */ +void +clkill (void) +{ + register struct pfile *pfp; + register int n, jn; + struct operand o; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) <= 0) + cl_error (E_UERR, "must specify job number(s)"); + + pushbparams (pfp->pf_pp); /* push so first popped is first param */ + + while (n--) { + popop(); /* discard the $n name */ + opcast (OT_INT); /* insure we get an integer */ + o = popop(); /* pop job number, as int */ + jn = o.o_val.v_i; + + bkg_kill (jn); + } +} + + +/* EPARAM -- Parameter set editor. + */ +void +cleparam (void) +{ + register struct pfile *pfp; + int n, nleft, quit; + struct operand o; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) <= 0) + return; + + pushbparams (pfp->pf_pp); /* push so first popped is first param */ + quit = NO; + + for (nleft=n; nleft > 0; nleft--) { + popop(); /* discard the $n name */ + o = popop(); /* get task name (value of the param) */ + + if (!quit && (o.o_type & OT_BASIC) == OT_STRING) + quit = (epset (o.o_val.v_s) == ERR); + else + cl_error (E_UERR, + "eparam: argument must be taskname or pfilename"); + } +} + + +/* LPARAM name1, name2, ... + * go through params for each named task and list their names, current value, + * and prompt string. go through twice, giving all non-hidden ones first. + * if a pfile is needed and it is not in core already, it is read in just + * long enough to display then discarded. it might be argued that lparam + * should have a kind of implied pre-loading cache effect since a task whose + * params are being inspected is likely to be used soon. if this effect is + * wanted, just add the topd saving line as with task, cache, etc. + */ +void +cllparam (void) +{ + register struct ltask *ltp; + register struct pfile *pfp; + struct operand o; + int n, nleft; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) <= 0) + return; + + pushbparams (pfp->pf_pp); /* push so first popped is first param */ + + for (nleft=n; nleft > 0; nleft--) { + popop(); /* discard the $n name */ + o = popop(); /* get task name (value of the param) */ + if ((o.o_type & OT_BASIC) == OT_STRING) { + pfp = pfilesrch (o.o_val.v_s); + ltp = pfp->pf_ltp; + if (n > 1) + oprintf (" %s:\n", ltp->lt_lname); + listparams (pfp); + } else + cl_error (E_UERR, "lparam: argument must be a taskname"); + } +} + + +/* DPARAM name1, name2, ... + * Dump the parameters for the named tasks to the standard output in the + * form of a series of `task.param=value' assignments. + */ +void +cldparam (void) +{ + register struct ltask *ltp; + register struct pfile *pfp; + struct operand o; + int n, nleft; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) <= 0) + return; + + pushbparams (pfp->pf_pp); /* push so first popped is first param */ + + for (nleft=n; nleft > 0; nleft--) { + popop(); /* discard the $n name */ + o = popop(); /* get task name (value of the param) */ + + if ((o.o_type & OT_BASIC) == OT_STRING) { + pfp = pfilesrch (o.o_val.v_s); + ltp = pfp->pf_ltp; + dumpparams (pfp); + } else + cl_error (E_UERR, "dparam: argument must be a taskname"); + } +} + + +/* PACKAGE name + * this function is to create a new package structure off pachead + * so that when the previous process continues, it will be its new curpack. + * the packages pfile is to be the parent's also. + * since we want the effect to remain for the parent, we store the new + * package pointer in (currentask+1)->t_curpack so restor() will stuff it + * into curpack. we also need to "keep" the new topd so that restor doesn't + * lob off the new package again. this is a complexity that results from + * running builtin functions as tasks in their own right. + * no point in setting curpack as it will get overwritten by restor() as soon + * as this returns. + * if called without arguments, just give a list of packages, in current + * circular search order. + * set LT_DEFPCK if the new package name is the same as the task defining it. + * used by cmdsrch() to guard against rerunning a script that defines a pkg. + * call error() and do not return if this would redefine the package. + */ +void +clpack (void) +{ + register struct pfile *pfp; + register struct task *tp; + register struct package *pkp; + char *paknam, *bindir; + struct operand o1, o2; + int n; + + pfp = newtask->t_pfp; + if (nargs (pfp) > 2) + cl_error (E_UERR, "too many arguments"); + + if ((n = nargs(pfp)) == 0) { + pkp = curpack; + do { + oprintf (" %s\n", pkp->pk_name); + if ((pkp = pkp->pk_npk) == NULL) + pkp = reference (package, pachead); + } until (pkp == curpack); + return; + } + + /* Get name of new package. */ + pushbparams (pfp->pf_pp); + popop(); /* discard param's $n name */ + opcast (OT_STRING); + o1 = popop(); + paknam = o1.o_val.v_s; + + /* Search up the task stack for a script task with the same name as + * the new package. Note that if other packages were loaded before + * the PACKAGE statement was executed, the task descriptor for the + * package script task will not be the previous task. + */ + for (tp = prevtask; tp != firstask; tp = next_task(tp)) + if (!strcmp (paknam, tp->t_ltp->lt_lname)) + break; + + /* Determine the bindir for the package. This may be given on the + * command line, otherwise we inherit the bindir of the package to + * which the new package being defined belongs. + */ + if (n > 1) { + opcast (OT_STRING); + o2 = popop(); + opcast (OT_STRING); + o2 = popop(); + bindir = o2.o_val.v_s; + } else + bindir = tp->t_ltp->lt_pkp->pk_bin; + + /* Check for redefinition. */ + if (pacfind (paknam) != NULL) + cl_error (E_UERR, "package redefinition: `%s'", paknam); + + /* Enter the new package definition into the dictionary. */ + pkp = newpac (paknam, bindir); + + /* Set the pfile pointer for the new package to the pfile for the + * containing script task of the same name. Flag the ltask entry + * to indicate that the ltask is a package. + */ + pkp->pk_pfp = tp->t_pfp; + tp->t_ltp->lt_flags |= LT_DEFPCK; + + /* Set the current process cache process number (assigned in time + * order) for the task immediately preceding the one which called + * us. This causes restor() to prune all recently connected processes + * from the process cache when we exit. + */ + if (tp != firstask) + next_task(tp)->t_pno = pr_getpno(); + + /* Patch the saved curpack of the previous task (whatever it was) so + * that when we return the newly declared package will become the + * current package. Call KEEP so that the new entry does not go away + * when the PACKAGE decl-task exits. + */ + prevtask->t_curpack = pkp; + keep (prevtask); +} + + +/* _CURPACK -- Print the name of the "current" package, i.e., the name of + * the first package in the search path for a command. + */ +void +clcurpack (void) +{ + tprintf ("%s\n", curpack->pk_name); +} + + +/* clpackage + * this is just a null function to allow changing the current package to + * clpackage. it is necessary due to the way cmdsrch() works, which looks + * for an ltask named clpackage, then checks to see if there is a package + * of the same name. if there is, it changes to it. thus, we need a fake + * "task" for cmdsrch() to find so we may change to clpackage. + */ +void +clpkg (void) +{ +} + +/* language + * Fake task for the "language" package. + */ +void +lapkg (void) +{ +} + + +/* CLPRINT -- Formatted output. Print arguments on the standard + * output. + */ +void +clprint (void) +{ + do_clprint ("stdout"); +} + + +/* CLFPRINT -- Formatted output. Print arguments 2-N on the stream or + * in the param named by the first argument. + */ +void +clfprint (void) +{ + do_clprint (""); +} + + +void +do_clprint ( + char *dest +) +{ + /* x1 and x2 are just place holders for the call to breakout. + */ + struct pfile *pfp; + struct param *pp; + FILE *fout; + char *pkname, *ltname, *pname, *field; + char outbuf[SZ_LINE]; + struct operand o, out; + int type, op, n, nleft; + + pfp = newtask->t_pfp; + pushbparams (pfp->pf_pp); /* push so first popped is first param */ + + /* Get the number of the first argument. If not "$1", i.e. when + * calling as "print (,x,y,z)", default dest to the standard output. + * Otherwise, get the first parameter (name of the destination + * stream or param) and save for later. + */ + + if ((n = nargs (pfp)) < 1) + goto argerr; + + out = popop(); /* get argument number "$n" */ + if (strcmp (dest, "stdout") == 0 || strcmp (out.o_val.v_s, "$1") != 0) { + /* n == 1 is ok here: syntax "print (,xx)" */ + pushop (&out); + out.o_val.v_s = "stdout"; + } else { + out = popop(); /* get dest name (param name or stream) */ + if (n == 1) +argerr: cl_error (E_UERR, "Too few arguments to print or fprint"); + n = n - 1; + } + + /* Format the output string. + */ + op = 0; + outbuf[op] = '\0'; + for (nleft = n; nleft > 0; nleft--) { + popop(); /* discard the $n name */ + o = popop(); + sprop (&outbuf[op], &o); + while (outbuf[op] != '\0') + op++; + /* If operand is a number, add a space after the number. + */ + type = o.o_type & OT_BASIC; + if (type == OT_INT || (type == OT_REAL && nleft > 1)) { + outbuf[op++] = ' '; + outbuf[op] = '\0'; + } + if (op >= SZ_LINE) + cl_error (E_UERR, "Output line too long in 'print'"); + } + + /* Examine the destination string and output the formatted + * string. Destination may be stdout, stderr, or a parameter. + */ + breakout (out.o_val.v_s, &pkname, <name, &pname, &field); + + makelower (pname); + fout = NULL; + if (pkname[0] == '\0' && ltname[0] == '\0') { + if (strcmp (pname, "stdout") == 0 || pname[0] == '\0') + fout = currentask->t_stdout; + else if (strcmp (pname, "stderr") == 0) + fout = currentask->t_stderr; + } + + if (fout != NULL) { /* send to task stdout or err */ + outbuf[op++] = '\n'; /* append newline */ + outbuf[op] = '\0'; + fputs (outbuf, fout); + } else { + o.o_type = OT_STRING; /* destination is a param */ + o.o_val.v_s = outbuf; + pushop (&o); + pp = paramsrch (pkname, ltname, pname); + paramset (pp, field[0]); + } +} + + +/* CLPRINTF -- Formatted print command (interface to VOS printf). + */ +void +clprintf (void) +{ + struct pfile *pfp; + struct operand o; + int arg, n; + + pfp = newtask->t_pfp; + pushbpvals (pfp->pf_pp); + if ((n = nargs (pfp)) < 1) + cl_error (E_UERR, "printf: insufficient arguments\n"); + + /* Output format. */ + o = popop(); + if ((o.o_type & OT_BASIC) != OT_STRING) + cl_error (E_UERR, "printf: bad format string\n"); + c_fprintf (fileno(currentask->t_stdout), o.o_val.v_s); + + /* Pass the operand values. */ + for (arg=2; arg <= n; arg++) { + o = popop(); + if (opindef(&o)) { + c_pargstr ("INDEF"); + } else if (opundef(&o)) { + cl_error (E_UERR, "printf: argument %d has undefined value\n", + arg); + } else { + switch (o.o_type & OT_BASIC) { + case OT_BOOL: + case OT_INT: + c_pargi (o.o_val.v_i); + break; + case OT_REAL: + c_pargd (o.o_val.v_r); + break; + case OT_STRING: + c_pargstr (o.o_val.v_s); + break; + default: + cl_error (E_UERR, "printf: bad operand type\n"); + } + } + } +} + + +/* CLSCAN -- The scan function called as a task to scan from the standard + * input, e.g. a pipe. (Name changed to clscans to avoid a name clash + * with fmtio.clscan). + */ +void +clscans (void) +{ + struct pfile *pfp; + + pfp = newtask->t_pfp; + pushbpvals (pfp->pf_pp); + cl_scan (nargs(pfp)-1, "stdin"); + popop(); +} + + +/* CLSCANF -- Formatted scan function. + */ +void +clscanf (void) +{ + struct pfile *pfp; + struct operand o; + int n; + + pfp = newtask->t_pfp; + pushbpvals (pfp->pf_pp); + if ((n = nargs (pfp)) < 1) + cl_error (E_UERR, "scanf: insufficient arguments\n"); + + /* Get scan format. */ + o = popop(); + if ((o.o_type & OT_BASIC) != OT_STRING) + cl_error (E_UERR, "scanf: bad format string\n"); + + cl_scanf (o.o_val.v_s, nargs(pfp)-2, "stdin"); + popop(); +} + + +/* PUTLOG user-msg + * Write a user message to the logfile. The current pkg.task, bkg info, and + * a time stamp are added by the putlog() function (in history.c). + */ +void +clputlog (void) +{ + register struct pfile *pfp; + struct operand o; + char *usermsg; + int n; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) < 1) + usermsg = ""; + else { + pushbparams (pfp->pf_pp); + popop(); /* discard fake name. */ + opcast (OT_STRING); + o = popop(); /* get user string */ + usermsg = o.o_val.v_s; + while (--n) { /* get rid of any extra args */ + popop(); /* discard fake name */ + popop(); /* discard extra arg */ + } + } + + /* Call putlog with the calling task and the user's message. + */ + putlog (prevtask, usermsg); +} + + +/* set [name = value] + * if (no arguments) + * give a list of existing enviroment settings + * else + * add an entry into the environment table name=value. + * update environ list in all connected child procs. + */ +void +clset (void) +{ + register struct pfile *pfp; + struct operand onam, oval; + int scantemp, n, show_redefs=YES; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) == 0) + c_envlist (fileno(currentask->t_stdout), " ", show_redefs); + else { + pushfparams (pfp->pf_pp); + while (n--) { + opcast (OT_STRING); + onam = popop(); + if (sscanf (onam.o_val.v_s, "$%d", &scantemp) == 1) + cl_error (E_UERR, "set must use name=value pairs"); + opcast (OT_STRING); + oval = popop(); + c_envputs (onam.o_val.v_s, oval.o_val.v_s); + pr_envset (0, onam.o_val.v_s, oval.o_val.v_s); + } + + /* Prevent envfree in poptask when SET terminates from discarding + * this definition!! + */ + c_envmark (&prevtask->t_envp); + } +} + + +/* reset [name = value] + * if (no arguments) + * give a list of existing enviroment settings + * else + * reset (overwrite) the value of the named environment variable. + * update environ list in all connected child procs. + */ +void +clreset (void) +{ + register struct pfile *pfp; + struct operand onam, oval; + int scantemp, n, show_redefs=YES; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) == 0) + c_envlist (fileno(currentask->t_stdout), " ", show_redefs); + else { + pushfparams (pfp->pf_pp); + while (n--) { + opcast (OT_STRING); + onam = popop(); + if (sscanf (onam.o_val.v_s, "$%d", &scantemp) == 1) + cl_error (E_UERR, "reset must use name=value pairs"); + opcast (OT_STRING); + oval = popop(); + c_envreset (onam.o_val.v_s, oval.o_val.v_s); + pr_envset (0, onam.o_val.v_s, oval.o_val.v_s); + } + + /* Prevent envfree in poptask when SET terminates from discarding + * this definition!! + */ + c_envmark (&prevtask->t_envp); + } +} + + +/* show [name] + * if (no arguments) + * give a list of existing enviroment settings, but do not show redefinitions + * as 'set' does. + * else + * show value of specified environment variable(s). + */ +#define SZ_VALUE SZ_COMMAND + +void +clshow (void) +{ + register struct pfile *pfp; + struct operand onam; + int n, show_redefs=NO; + char val[SZ_VALUE]; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) == 0) + c_envlist (fileno(currentask->t_stdout), " ", show_redefs); + else { + pushbparams (pfp->pf_pp); /* push so first popped is first param */ + while (n--) { + popop(); /* discard the $n */ + opcast (OT_STRING); + onam = popop(); + if (c_envfind (onam.o_val.v_s, val, SZ_VALUE) < 0) + cl_error (E_UERR, "No such environment variable"); + else + oprintf ("%s\n", val); + } + } +} + + +/* STTY -- Set terminal driver options. This is merely an interface to the VOS + * sttyco() procedure, which does all the work. Our function is merely to + * collect the arguments into a long string and then call sttyco() to perform + * the operation. The dictionary must be "kept" after the call to sttyco since + * new values of the terminal, ttyncols, and ttynlines variables may be set. + */ +void +clstty (void) +{ + register struct pfile *pfp; + register char *ip, *op; + char sttycmd[2048], args[1024], *argp[100]; + int argc, i; + XINT std_in = STDIN, std_out = STDOUT; + + + pfp = newtask->t_pfp; + + /* Construct an array of pointers to the argument strings. argp[1] is + * the first argument; argp[0] is the task name. + */ + argc = mkarglist (pfp, args, argp); + + /* Concatenate the stty argument list. */ + for (op=sttycmd, i=1; i <= argc; i++) { + for (ip=argp[i]; (*op = *ip++); op++) + ; + if (i < argc) + *op++ = ' '; + } + *op++ = EOS; + + /* Call STTYCO to set the terminal driver options. */ + c_sttyco (sttycmd, std_in, std_out, fileno(newtask->t_stdout)); + keep (prevtask); +} + + +/* TASK [lname1, lname2, ...,] lnamen = pname + * Define the one or more logical tasks to be in the given physical file name. + * The new task defn's will built starting at topd, which has already been + * reset to what it was before the call to this built started. Thus, the + * params pointed to by t_pfp will be overwritten and they must be saved. + * Also, we need to "keep" the new topd so restor doesn't lob off the new + * structures when going back to the previous task. See the disclaimer with + * clpack(). + * + * Task names which begin with underscore are invisible to the user and + * are not shown in menus. The LT_INVIS flag is set by "addltask" if the + * first char in the task name is an underscore. + */ +void +cltask ( + int redef +) +{ + register struct pfile *pfp; + struct operand o; + int n, scantmp; + char *physname, *logname; + int foreign_task, flags; + + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) <= 0) + cl_error (E_UERR, e_geonearg, "task"); + + pushfparams (pfp->pf_pp); /* push so first popped is last param */ + o = popop(); + logname = o.o_val.v_s; + if (sscanf (logname, "$%d", &scantmp) == 1) + cl_error (E_UERR, + "physical task name must be explicit in last arg"); + + opcast (OT_STRING); + o = popop(); + physname = o.o_val.v_s; + + /* Check for a foreign (host system) task, a type of builtin. + */ + if ((foreign_task = (*physname == '$'))) { + if (strcmp (physname, "$foreign") == 0) + physname = ""; + else + physname++; + } + + if (foreign_task) { + flags = LT_FOREIGN; + if (logname[0] == '$') { + logname++; + flags &= ~LT_PFILE; + } + newbuiltin (curpack, logname, clforeign, flags, physname, redef); + } else + addltask (curpack, physname, logname, redef); + + while (--n) { + popop(); /* discard $n param name */ + opcast (OT_STRING); + o = popop(); /* get logical name */ + logname = o.o_val.v_s; + + if (foreign_task) { + flags = LT_FOREIGN; + if (logname[0] == '$') { + logname++; + flags &= ~LT_PFILE; + } + newbuiltin (curpack, logname,clforeign,flags,physname, redef); + } else + addltask (curpack, physname, o.o_val.v_s, redef); + } + + keep (prevtask); /* retain changes for prev task */ +} + +/* these are hooks to cltask that just select whether redefs are to be + * permitted. they are both used as described for cltask(). + */ +void +clrtask (void) +{ + cltask (YES); +} + +void +clntask (void) +{ + cltask (NO); +} + + +/* CLFOREIGN -- Execute a foreign task. A foreign task is a special type of + * builtin task to the CL. All foreign tasks vector to CLFOREIGN for + * execution. Our function is to build up a command line for the foreign + * task and submit it to the host system for execution with c_oscmd(). + * The parameters to a foreign task are output as blank separated strings + * in pfile order. The name of the foreign task defaults to the same as the + * name of the ltask. Commonly foreign tasks have no pfile, hence the + * parameters are whatever the user entered on the command line. Note however + * that a parameter string may be the result of any CL expression; the argument + * list of a foreign task is parsed by the CL like it is for any task. + * CL metacharacters must be quoted or escaped to be included as strings in + * the command line to the host system. I/O redirection is supported. + * + * A foreign task command line is built up by argument substitution, scanning + * the so-called `ftprefix' command template string for symbolic argument + * references of the form $1, $2, etc., to match individual arguments, or $* + * to match the full argument list. $(N) denotes the host equivalent of + * virtual filename argument N. If no $arg references are found the argument + * list is simply appended to the ftprefix string, in which case it really is + * a prefix string. + */ +void +clforeign (void) +{ + register struct pfile *pfp; + register char *ip, *op; + char oscmd[1024], args[1024], *argp[100], *ap; + int dolseen, mapfname; + int argc, n1, n2, ch, n; + + pfp = newtask->t_pfp; + + /* Construct an array of pointers to the argument strings. argp[1] is + * the first argument; argp[0] is the task name. + */ + argc = mkarglist (pfp, args, argp); + + /* Build up the host command by inserting the CL command line arguments + * into the command template given in the foreign task declaration. + */ + dolseen = 0; + for (ip=newtask->t_ltp->lt_ftprefix, op=oscmd; (*op = *ip); op++,ip++) { + if (*ip == '\\' && *(ip+1) == '$') + *op = *(++ip); + else if (*ip == '$') { + dolseen++; + ch = *(++ip); + + /* A $(N) or $(*) causes the argument strings to be treated as + * virtual filenames and mapped into their host equivalents for + * use in the host command string. + */ + mapfname = 0; + if (ch == '(') { + mapfname++; + ch = *(++ip); + ip++; + } + + if (isdigit (ch)) { + n1 = n2 = ch - '0'; + } else if (ch == '*') { + n1 = 1; + n2 = argc; + } else { + *(++op) = ch; + continue; + } + + for (n=n1; n <= n2; n++) { + char osfn[SZ_PATHNAME+1]; + + if (n >= 0 && n <= argc) { + if (n > n1) + *op++ = ' '; + if (mapfname) { + c_fmapfn (argp[n], osfn, SZ_PATHNAME); + ap = osfn; + } else + ap = argp[n]; + while ( (*op = *ap++) ) + op++; + } + } + + op--; + } + } + + /* If there were no $arg references in the command template, append + * the argument list to the prefix string. + */ + if (!dolseen) + for (n=1; n <= argc; n++) { + *op++ = ' '; + for (ap=argp[n]; (*op = *ap++); op++) + ; + } + + if (cltrace) { + d_fmtmsg (stderr, "\t ", oscmd, 80 - 13); + eprintf ("\t--------------------------------\n"); + } + + /* Call the host system to execute the command. If i/o redirection + * was indicated on the command line pointers to the names of the + * referenced files will have been stored in the task structure by + * the CL metacode instructions o_redir, o_redirall, etc. If the + * task was called by a parent whose output was redirected then we + * must call clsystem, which will spool the output of the OS cmd + * in temporary files and then copy it to the parent's output streams. + */ + if ((newtask->t_stdout != stdout && newtask->ft_out == NULL) || + (newtask->t_stderr != stderr && newtask->ft_err == NULL)) { + + clsystem (oscmd, newtask->t_stdout, newtask->t_stderr); + + } else { + /* Parents i/o is not redirected, hence we can redirect i/o + * directly without a temp file. + */ + char *in, *out, *err; + int append_all; + + in = newtask->ft_in ? newtask->ft_in : "", + out = newtask->ft_out ? newtask->ft_out : "", + err = newtask->ft_err ? newtask->ft_err : ""; + append_all = (out == err); + + if (newtask->t_flags & T_APPEND) { + register int ch; + register FILE *fp=NULL, *outfp=NULL; + char tmpfile[SZ_PATHNAME]; + + /* Execute the command spooling the output in a temporary + * file (OSCMD cannot directly append to an output file). + */ + if (!c_mktemp ("tmp$ft", tmpfile, SZ_PATHNAME)) + strcpy (tmpfile, "tmp$ft.out"); + c_oscmd (oscmd, in, tmpfile, append_all ? tmpfile : err); + + /* Append the spooled output to the user-specified output + * redirection file. + */ + if ((fp = fopen (tmpfile, "r")) != NULL && + (outfp = fopen (out, "a")) != NULL) { + while ((ch = fgetc(fp)) != EOF) + fputc (ch, outfp); + } + + if (fp) + fclose (fp); + if (outfp) + fclose (outfp); + c_delete (tmpfile); + + } else + c_oscmd (oscmd, in, out, err); + } +} + + +/* UNLEARN (ltask|package) [, (ltask|package)...] + * Restore the package default parameters for each ltask, or for all of + * the ltasks in the named package. + */ +void +clunlearn (void) +{ + static char errfmt[] = "Warning: Cannot unlearn params for `%s'\n"; + register struct pfile *pfp; + register struct ltask *ltp, *ltt; + char *x1, *pk, *t, *x2; + struct operand o; + int n; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) < 1) + cl_error (E_UERR, e_geonearg, "unlearn"); + + pushbparams (pfp->pf_pp); + while (n--) { + popop(); /* discard fake name. */ + opcast (OT_STRING); + o = popop(); /* get ltask|package name */ + breakout (o.o_val.v_s, &x1, &pk, &t, &x2); + if (!(ltp = cmdsrch (pk, t))) + continue; + + /* If package, unlearn each task. */ + if (ltp->lt_flags & LT_PACCL) { + /* Unlearn each task in the package. */ + for (ltt=ltp->lt_pkp->pk_ltp; ltt != NULL; ltt=ltt->lt_nlt) + if (pfileinit (ltt) == ERR) + eprintf (errfmt, ltt->lt_lname); + + /* Unlearn the package parameters. */ + if ( (ltt = ltasksrch (pk, t)) ) { + if (pfileinit(ltt) == ERR) + eprintf (errfmt, ltt->lt_lname); + } + + } else if (pfileinit (ltp) == ERR) + eprintf (errfmt, ltp->lt_lname); + } +} + + +/* UPDATE ltask [, ltask...] + * force the in-core pfile for the given tasks to be written out. + * used when the pfile has been pre-loaded with cache but it is to be + * saved before it would automatically be due to bye'ing task. + * since the given task might be running, if we were run from it for example, + * we also force the working copy to get copied back to its original. + * (the check that it is indeed a copy is in pfcopyback()). + */ +void +clupdate (void) +{ + /* x1 and x2 are just place holders for the call to breakout. + */ + register struct pfile *pfp; + register struct ltask *ltp; + char *x1, *pk, *t, *x2; + struct operand o; + int n; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) < 1) + cl_error (E_UERR, e_geonearg, "update"); + + pushbparams (pfp->pf_pp); + while (n--) { + popop(); /* discard fake name. */ + opcast (OT_STRING); + o = popop(); /* get ltask */ + breakout (o.o_val.v_s, &x1, &pk, &t, &x2); + ltp = ltasksrch (pk, t); + if (!(ltp->lt_flags & LT_PFILE)) + cl_error (E_UERR, e_nopfile, ltp->lt_lname); + if ((pfp = pfilefind (ltp)) == NULL) + cl_error (E_UERR, "pfile not loaded for `%s'", + ltp->lt_lname); + pfcopyback (pfp); /* IT checks whether pfp is a copy */ + pfileupdate (pfp); + } +} + +/* HIDETASK ltask [, ltask...] + * Set the flags for this task to LT_INVIS so that it does not + * become an active part of the users environment. This function does + * not require the underscore to hide the task. + */ +void +clhidetask (void) +{ + /* x1 and x2 are just place holders for the call to breakout. + */ + register struct pfile *pfp; + register struct ltask *ltp; + char *x1, *pk, *t, *x2; + struct operand o; + int n; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) < 1) + cl_error (E_UERR, e_geonearg, "hidetask"); + + pushbparams (pfp->pf_pp); + while (n--) { + popop(); /* discard fake name. */ + opcast (OT_STRING); + o = popop(); /* get ltask */ + breakout (o.o_val.v_s, &x1, &pk, &t, &x2); + ltp = ltasksrch (pk, t); + ltp->lt_flags |= LT_INVIS; + } +} + + +/* WAIT -- Wait for a job or jobs to terminate. The default is to wait for + * all jobs. + */ +void +clwait (void) +{ + register struct pfile *pfp; + register int n, jn; + struct operand o; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) <= 0) + jn = 0; + + pushbparams (pfp->pf_pp); /* push so first popped is first param */ + + if (n > 0) { + while (n--) { + popop(); /* discard the $n name */ + opcast (OT_INT); /* insure we get an integer */ + o = popop(); /* pop job number, as int */ + jn = o.o_val.v_i; + + bkg_wait (jn); + } + } else + bkg_wait (jn); +} + + +/* JOBS -- Show status of a job or jobs. The default is to show the status + * of all jobs running or that have recently run. + */ +void +cljobs (void) +{ + register struct pfile *pfp; + register int n, jn; + struct operand o; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) <= 0) { + bkg_jobstatus (currentask->t_stdout, 0); + return; + } + + pushbparams (pfp->pf_pp); /* push so first popped is first param */ + while (--n >= 0) { + popop(); /* discard the $n name */ + opcast (OT_INT); /* insure we get an integer */ + o = popop(); /* pop job number, as int */ + jn = o.o_val.v_i; + + bkg_jobstatus (currentask->t_stdout, jn); + } +} + + +/* CLFUNC -- Called when one of the dummy intrinsic functions entered in + * the language package (to prompt the user) is called as a task. + */ +void +clfunc (void) +{ + cl_error (E_UERR, "Function `%s' cannot be called as a task", + currentask->t_ltp->lt_lname); +} + + +/* BEEP -- Beep the terminal. + */ +void +clbeep (void) +{ + putchar ('\007'); +} + + +/* TIME -- Print the current time and date on the standard output. + */ +void +cltime (void) +{ + char buf[SZ_LINE]; + + c_cnvtime (c_clktime(0L), buf, SZ_LINE); + oprintf ("%s\n", buf); +} + + +/* CLEAR -- Clear the terminal screen and home the cursor. Uses the TTY + * package (device independent terminal interface), which requires an entry + * in the dev$termcap file for the terminal. In addition to clearing the + * screen, we also turn standout mode and raw mode off, just in case. + */ +void +clclear (void) +{ + XINT tty, sout = STDOUT; + + if ((tty = c_ttyodes ("terminal")) == ERR) + c_erract (EA_ERROR); + + c_ttyso (sout, tty, NO); + c_ttyclear (sout, tty); + c_ttycdes (tty); + c_fseti (sout, F_RAW, NO); +} + + +/* SLEEP -- Suspend execution for the specified number of seconds. + */ +void +clsleep (void) +{ + register struct pfile *pfp; + struct operand o; + + pfp = newtask->t_pfp; + pushbparams (pfp->pf_pp); /* push sofirst popped is first param */ + if ( nargs (pfp) <= 0) + return; + else { + popop(); /* discard the $n name */ + opcast (OT_INT); + o = popop(); /* get the number of seconds */ + c_tsleep (o.o_val.v_i); + } +} + + +/* EDIT -- Call up a host system editor to edit a file. The name of the editor + * to be used is defined in the IRAF environment. The command to be sent to + * the host system to run the editor is defined by an SPRINTF style format + * string in the EDCAP editor database. The SPRINTF format is assumed to + * contain exactly one %s sequence to be replaced by the name of the file(s) + * to be edited. If no %s sequence is present in the EDCAP entry, the + * host_editor() function will add one at the end so that the filenames are + * concatenated to the string in the EDCAP entry. + */ +void +cledit (void) +{ + register struct pfile *pfp; + char oscmd[SZ_LINE], os_filelist[SZ_LINE]; + char osfn[SZ_PATHNAME]; + struct operand o; + char *envget(); + int n; + + pfp = newtask->t_pfp; + + if ((n = nargs(pfp)) > 0) { + pushbparams (pfp->pf_pp); + + /* Process the argument list into a list of files to be edited. + */ + os_filelist[0] = EOS; + while (--n >= 0) { + popop(); /* discard the $1 */ + o = popop(); + c_fmapfn (o.o_val.v_s, osfn, SZ_PATHNAME); + if (os_filelist[0] != EOS) + strcat (os_filelist, " "); + strcat (os_filelist, osfn); + } + } + + /* Format the host editor command, and call the host system editor + * to edit the file(s). + */ + sprintf (oscmd, host_editor (envget ("editor")), os_filelist); + c_oscmd (oscmd, "", "", ""); +} + + +/* _ALLOCATE -- Allocate a device. The parent process (i.e. the CL) allocates + * (or mounts, depending on the system) the device, rendering it ready for + * exclusive i/o by any subprocesses. (Called from the allocate.cl and + * deallocate.cl scripts in the SYSTEM pkg.) + */ +void +clallocate (void) +{ + register struct pfile *pfp; + register int n; + static char noalloc[] = "cannot allocate device %s"; + struct operand o; + char device[SZ_FNAME+1]; + char owner[SZ_FNAME+1]; + + pfp = newtask->t_pfp; + if ((n = nargs (pfp)) == 0) + return; + + pushbparams (pfp->pf_pp); + popop(); /* throw $1 away */ + opcast (OT_STRING); /* param 1 == device */ + o = popop(); + strcpy (device, o.o_val.v_s); + + /* Verify that the device can be allocated. + */ + switch (c_devowner (device, owner, SZ_FNAME)) { + case DV_DEVFREE: + break; /* ok to allocate */ + case DV_DEVALLOC: + eprintf ("device %s is already allocated\n", device); + return; /* already allocated */ + case DV_DEVINUSE: + cl_error (E_UERR, "device %s is already allocated to %s\n", + device, owner); + default: + cl_error (E_UERR, noalloc, device); + } + + /* Allocate the device. */ + if (c_allocate (device) == ERR) + cl_error (E_UERR, noalloc, device); + + /* Keep count and save names of allocated devices. + */ + for (n=0; n < MAX_ALLOCDEV; n++) { + if (!allocdev[n].allocated) + continue; + if (strcmp (allocdev[n].devname, device) == 0) + return; /* device already in table */ + } + + /* Find empty slot */ + for (n=0; n < MAX_ALLOCDEV && allocdev[n].allocated; n++) + ; + if (n >= MAX_ALLOCDEV) + cl_error (E_UERR, "too many allocated devices"); + + /* Save name of device */ + strncpy (allocdev[n].devname, device, SZ_DEVNAME); + allocdev[n].devname[SZ_DEVNAME] = EOS; + allocdev[n].allocated = 1; + nallocdev++; +} + + +/* _DEALLOCATE -- Deallocate a device. + */ +void +cldeallocate (void) +{ + register struct pfile *pfp; + register int n; + static char nodealloc[] = "cannot deallocate device %s"; + struct operand o; + char device[SZ_FNAME+1]; + char owner[SZ_FNAME+1]; + int rewind=0, n_args; + + pfp = newtask->t_pfp; + if ((n_args = nargs (pfp)) <= 0) + return; + + pushbparams (pfp->pf_pp); /* params in correct order */ + popop(); /* throw $1 away */ + opcast (OT_STRING); /* param 1 == device name */ + o = popop(); + strcpy (device, o.o_val.v_s); + + if (n_args > 1) { + popop(); /* throw $2 away */ + opcast (OT_BOOL); /* param 2 == rewind flag */ + o = popop(); + rewind = o.o_val.v_i; + } + + /* Verify that the device can be deallocated. + */ + switch (c_devowner (device, owner, SZ_FNAME)) { + case DV_DEVFREE: + eprintf ("device %s is not allocated\n", device); + return; + case DV_DEVALLOC: + break; /* ok to deallocate */ + case DV_DEVINUSE: + cl_error (E_UERR, "device %s is currently allocated to %s\n", + device, owner); + default: + cl_error (E_UERR, nodealloc, device); + } + + /* Deallocate the device. */ + if (c_deallocate (device, rewind) == ERR) + cl_error (E_UERR, nodealloc, device); + + /* Keep count and save names of allocated devices. + */ + for (n=0; n < MAX_ALLOCDEV; n++) { + if (!allocdev[n].allocated) + continue; + if (strcmp (allocdev[n].devname, device) == 0) { + allocdev[n].allocated = 0; + --nallocdev; + break; + } + } +} + + +/* _DEVSTATUS -- Print the status of an allocatable device on the standard + * output. + */ +void +cldevstatus (void) +{ + register struct pfile *pfp; + struct operand o; + char device[SZ_FNAME+1]; + + pfp = newtask->t_pfp; + if (nargs (pfp) <= 0) + return; + + pushbparams (pfp->pf_pp); /* params in correct order */ + popop(); /* throw $1 away */ + opcast (OT_STRING); /* param 1 == device name */ + o = popop(); + strcpy (device, o.o_val.v_s); + + /* Print the device status. */ + c_devstatus (device, STDOUT); +} + + +/* ---------------------------------------------- + * End of builtin functions. + * What follows is their support code. + */ + +/* SETBUILTINS -- Add the builtin functions to package at pkp (this should + * always just be clpackage). To add more functions, write the support function + * and enter it into the builtin table, btbl. Reverse alpha due to lifo nature + * of list. Aliases can be made easily with multiple b_names using the same + * b_f. Setting LT_INVIS will keep it from being seen in the menu. + */ +void +setbuiltins ( + register struct package *pkp +) +{ + /* Debugging functions are in debug.c. + */ + extern void d_f(), d_l(), d_d(), d_off(), d_on(), d_p(), d_t(); + extern void pr_listcache(); + + static struct builtin { + char *b_name; + void (*b_f)(); + int b_flags; + } btbl[] = { + { "d_f", d_f, LT_INVIS}, /* shows available file des */ + { "d_l", d_l, LT_INVIS}, /* shows defined ltasks i */ + { "d_m", d_d, LT_INVIS}, /* shows memory usage */ + { "d_off", d_off, LT_INVIS}, /* disables debuggin msgs */ + { "d_on", d_on, LT_INVIS}, /* enables debuging msgs */ + { "d_trace",dotrace,LT_INVIS},/* instruction tracing */ + { "d_p", d_p, LT_INVIS}, /* shows loaded param files */ + { "d_t", d_t, LT_INVIS}, /* shows running tasks */ + { "prcache", clprcache, 0}, /* show process cache */ + { "?", clhelp, LT_INVIS}, /* tasks in current package */ + { "??", clallhelp, LT_INVIS}, /* all tasks in all packs */ + { "wait", clwait, 0}, /* wait for all bkg jobs */ + { "jobs", cljobs, 0}, /* show status of bkg jobs */ + { "unlearn", clunlearn, 0}, /* unlearn params */ + { "update", clupdate, 0}, /* write out a changed pfile */ + { "hidetask",clhidetask, 0}, /* make these tasks invisible */ + { "task", clntask, 0}, /* define new ltask/ptask */ + { "set", clset, 0}, /* make environ table entry */ + { "reset", clreset, 0}, /* reset value of envvar */ + { "show", clshow, 0}, /* show value of environ var */ + { "stty", clstty, 0}, /* set terminal driver options */ + { "redefine", clrtask, 0}, /* redfine ltasl/ptask */ + { "package", clpack, 0}, /* define new package */ + { "_curpack", clcurpack, + LT_INVIS}, /* name the current package */ + { "print", clprint, 0}, /* formatted output to stdout */ + { "printf", clprintf, 0}, /* formatted output to stdout */ + { "fprint", clfprint, 0}, /* formatted output */ + { "putlog", clputlog, 0}, /* put a message to the logfile */ + { "dparam", cldparam, 0}, /* dump params for tasks */ + { "lparam", cllparam, 0}, /* list params for tasks */ + { "eparam", cleparam, 0}, /* edit params for tasks */ + { "ehistory", clehistory, 0}, /* edit command history */ + { "history", clhistory, 0}, /* print command history */ + { "service", clservice, 0}, /* respond to bkg query */ + { "kill", clkill, 0}, /* kill a background job */ + { "keep", clkeep, 0}, /* keep new defn's after bye */ + { "error", clerror, 0}, /* error msg from child */ + { ROOTPACKAGE, lapkg, + LT_INVIS|LT_DEFPCK}, /* fake task for language. */ + { CLPACKAGE, clpkg, + LT_INVIS|LT_DEFPCK}, /* fake task for clpackage. */ + { "chdir", clchdir, 0}, /* change directory */ + { "cd", clchdir, 0}, /* change directory */ + { "back", clback, 0}, /* change to previous directory */ + { "flprcache", clflprcache, 0},/* flush the process cache */ + { "gflush", clgflush, 0}, /* flush graphics output */ + { "cache", clcache, 0}, /* pre-load a tasks pfile */ + { "which", clwhich, 0}, /* locate named task */ + { "whereis", clwhereis, 0}, /* locate all instances of task */ + { "clbye", clclbye, LT_CL|LT_CLEOF}, /* cl() with EOF */ + { "bye", clbye, 0}, /* restore previous state */ + { "logout", cllogout, 0}, /* log out of the CL */ + + { "scan", clscans, 0}, /* scan from a pipe */ + { "scanf", clscanf, 0}, /* formatted scan */ + { "fscan", clfunc, 0}, /* intrinsic function entries */ + { "defpac", clfunc, 0}, /* " */ + { "defpar", clfunc, 0}, /* " */ + { "defvar", clfunc, 0}, /* " */ + { "deftask", clfunc, 0}, /* " */ + { "access", clfunc, 0}, /* " */ + { "imaccess", clfunc, 0}, /* " */ + { "mktemp", clfunc, 0}, /* " */ + { "envget", clfunc, 0}, /* " */ + { "radix", clfunc, 0}, /* " */ + { "osfn", clfunc, 0}, /* " */ + { "beep", clbeep, 0}, /* beep the terminal */ + { "time", cltime, 0}, /* show the current time */ + { "clear", clclear, 0}, /* clear the terminal screen */ + { "edit", cledit, 0}, /* edit a file or files */ + { "sleep", clsleep, 0}, /* suspend process execution */ + { "_allocate", clallocate, LT_INVIS}, + { "_deallocate", cldeallocate, LT_INVIS}, + { "_devstatus", cldevstatus, LT_INVIS} + }; + + register struct builtin *bp; + + for (bp = btbl; bp < &btbl[sizeof(btbl)/sizeof(struct builtin)]; bp++) + newbuiltin (pkp, bp->b_name, bp->b_f, bp->b_flags, "", 0); +} + + +/* NEWBUILTIN -- Make a new ltask off pkp that will serve as a cl directive + * builtin function. Link in exactly the same fashion as newltask() but use + * lt_f rather than lt_pname. See paramsrch(). FP is a pointer to the function + * that will perform the directive. Flags is to be or'd in with lt_flags in + * the new ltask. Call error if no more core. + */ +void +newbuiltin ( + struct package *pkp, /* package which owns task */ + char *lname, /* ltask name */ + void (*fp)(), /* pointer to builtin fcn */ + int flags, /* task flags */ + char *ftprefix, /* OSCMD prefix if foreign */ + int redef /* permit redefinitions */ +) +{ + register struct ltask *newltp; + + newltp = addltask (pkp, NULL, lname, redef); + + /* If no OSCMD prefix string is given use the logical task name, + * which must therefore be the same as the host task name. + */ + if (*ftprefix) + newltp->lt_ftprefix = comdstr (ftprefix); + else + newltp->lt_ftprefix = newltp->lt_lname; + + newltp->lt_f = fp; + newltp->lt_flags = (flags | LT_BUILTIN); +} + + +/* MKARGLIST -- Reconstruct the argument list of a task as an array of arg + * pointers to arg strings of the form "expr" or "keyword=value". Upon + * output, argp[0] contains the task name and the function value is the + * number of arguments, excluding argp[0]. + */ +int +mkarglist ( + register struct pfile *pfp, /* pfile pointer */ + char *args, /* string buffer for arg chars */ + char *argp[] /* array of arg pointers */ +) +{ + register char *ip, *op; + struct operand o_v, o_n; + int argc, n; + + + /* Construct an array of pointers to the argument strings. argp[1] is + * the first argument; argp[0] is the task name. + */ + if ((argc = nargs(pfp)) > 0) { + pushbparams (pfp->pf_pp); + op = args; + + argp[0] = newtask->t_ltp->lt_lname; + + for (n=1; n <= argc; n++) { + argp[n] = op; + + /* Get the parameter name. If this is $N then we have a + * positional argument, otherwise we have a keyword=value + * argument, and the arg should be encoded in that form. + */ + o_n = popop(); + ip = o_n.o_val.v_s; + if (*ip != '$') { + while ((*op = *ip++)) + op++; + *op++ = '='; + } + + /* Get the parameter value. */ + opcast (OT_STRING); + o_v = popop(); + ip = opindef(&o_v) ? "INDEF" : o_v.o_val.v_s; + while (ip && (*op++ = *ip++)) + ; + } + + argp[n] = NULL; + } + + return (argc); +} + + +/* PUSHFPARAMS -- Push the parameter list starting with pp forwards, that is, + * push the pp first and work towards the last parameter. Push two operands + * per parameter: first the value, then the name. Used when the parameters for + * a builtin will be accessed right-to-left. + */ +void +pushfparams ( + register struct param *pp +) +{ + struct operand onam; + + onam.o_type = OT_STRING; + for (; pp; pp = pp->p_np) { + paramget (pp, 'V'); + onam.o_val.v_s = pp->p_name; + pushop (&onam); + } +} + + +/* PUSHBPARAMS -- Push the parameter list starting with pp backwards, that is, + * push the last param in the list first and work back up to pp. Push two + * operands per parameter: first the value, then the name. Used when the + * parameters for a builtin will be accessed left-to-right. + */ +void +pushbparams ( + struct param *pp +) +{ + struct operand onam; + struct param *npp; + + if (pp == NULL) + return; /* just a guard */ + npp = pp->p_np; + if (npp != NULL) + pushbparams (npp); + + paramget (pp, 'V'); + onam.o_type = OT_STRING; + onam.o_val.v_s = pp->p_name; + pushop (&onam); +} + + +/* PUSHBPVALS -- Like pushbparams, but only the parameter value is pushed. + */ +void +pushbpvals ( + struct param *pp +) +{ + struct param *npp; + + if (pp == NULL) + return; /* just a guard */ + npp = pp->p_np; + if (npp != NULL) + pushbpvals (npp); + + paramget (pp, 'V'); +} + + +/* NARGS -- Count the number of parameters in a parameter list, and hence + * the number of command line arguments to a builtin. + */ +int +nargs ( + struct pfile *pfp +) +{ + struct param *pp; + int n; + + for (pp=pfp->pf_pp, n=0; pp != NULL; pp=pp->p_np) + n++; + + return (n); +} + + +/* KEEP -- Preserve additions to the dictionary and environment when the + * referenced task terminates. + */ +void +keep ( + register struct task *tp +) +{ + if (cldebug) { + eprintf ("currentask: %d, prevtask: %d\n",currentask,prevtask); + eprintf ("keep(): tp: %d\n",tp); + } + tp->t_topd = topd; + c_envmark (&tp->t_envp); +} diff --git a/pkg/cl/cl.par b/pkg/cl/cl.par new file mode 100644 index 00000000..3aa64019 --- /dev/null +++ b/pkg/cl/cl.par @@ -0,0 +1,56 @@ +# Parameter file for the IRAF command language. Defines all parameters +# affecting the operation of the CL (mode etc.), the global cursor list +# params, and some handy params of various data types: string(s1,s2,s3); +# integer(i,j,k); real(x,y,z). + +# Variables effecting cl operation. +args,s,h,,,,CL command line arguments +gcur,*gcur,a,,,,Graphics cursor +imcur,*imcur,a,,,,Image cursor +ukey,*ukey,a,,,,Global user terminal keyboard keylist +abbreviate,b,h,yes,,,Allow abbreviations in operand names? +echo,b,h,no,,,Echo CL command input on stderr? +ehinit,s,h,"nostandout eol noverify",,,Ehistory options string +epinit,s,h,"standout showall",,,Eparam options string +keeplog,b,h,no,,,Record all interactive commands in logfile? +logfile,f,h,"home$logfile.cl",,,Name of the logfile +logmode,s,h,"commands nobackground noerrors notrace",,,Logging control +lexmodes,b,h,yes,,,Enable conversational mode +menus,b,h,yes,,,Display menu when changing packages? +showtype,b,h,no,,,Add task-type suffix in menus? +notify,b,h,yes,,,Send done message when bkgrnd task finishes? +szprcache,i,h,4,1,10,Size of the process cache +version,s,h,"IRAF V2.16.1 Oct 2013",,,IRAF version +logver,s,h,"",,,login.cl version +logregen,b,h,no,,,Updating of login.cl to current version is advised +release,s,h,"2.16",,,IRAF release +mode,s,h,ql,,,CL mode of execution (query or query+learn) + +auto,s,h,a,,,The next 4 params are read-only. +query,s,h,q +hidden,s,h,h +learn,s,h,l +menu,s,h,m + +# Misc scratch and temp variables. +# Handy boolean variables for interactive use. +b1,b,h,,,,b1 +b2,b,h,,,,b2 +b3,b,h,,,,b3 +# Handy integer variables for interactive use. +i,i,h,,,,i +j,i,h,,,,j +k,i,h,,,,k +# Handy real variables for interactive use. +x,r,h,,,,x +y,r,h,,,,y +z,r,h,,,,z +# Handy string variables for interactive use. +s1,s,h,,,,s1 +s2,s,h,,,,s2 +s3,s,h,,,,s3 +# Handy parameter for reading lists (text files). +list,*s,h,,,,list +# Line buffer for list files. +line,struct,h,,,,line +... diff --git a/pkg/cl/cl.x b/pkg/cl/cl.x new file mode 100644 index 00000000..c792d371 --- /dev/null +++ b/pkg/cl/cl.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task cl = t_cl +procedure t_cl() +begin +end + +# CL -- The main entry point of the CL. Unlike most IRAF tasks, the CL task +# occupies a process all by itself and takes control immediately when the task +# is executed; the in-task interpreter never runs. The ONENTRY procedure is +# used to achieve this. ONENTRY gains control from the IRAF main at process +# startup, before the in task interpreter is entered. The t_cl procedure is +# not called by the interpreter as the TASK statement suggests. The purpose +# of the task statement is to give us an IRAF main. + +int procedure onentry (prtype, bkgfile, cmd) + +int prtype # process type flag (not used) +char bkgfile[ARB] # bkgfilename if detached process (not used) +char cmd[ARB] # optional host command line + +char pk_bkgfile[SZ_PATHNAME] +char pk_cmd[SZ_COMMAND] +int c_main() + +begin + call strpak (bkgfile, pk_bkgfile, SZ_PATHNAME) + call strpak (cmd, pk_cmd, SZ_COMMAND) + return (c_main (prtype, pk_bkgfile, pk_cmd)) +end diff --git a/pkg/cl/clmodes.h b/pkg/cl/clmodes.h new file mode 100644 index 00000000..87d9f4aa --- /dev/null +++ b/pkg/cl/clmodes.h @@ -0,0 +1,67 @@ +/* + * CLMODES.H -- Return a boolean result for the state of the various cl modes. + * Done by referring to the pointers declared in modes.c. + * The pointers are set up initially from the entry of the corresponding + * parameter in the cl's pfile. see setclmodes() in modes.c. + * abbreviations is hairy enough that is a real function in modes.c. + * A NULL pointer results in false, as does an undefined or indefinite value. + */ + +extern struct param *clecho; +#define echocmds() (clecho != NULL && \ + !(clecho->p_type & (OT_UNDEF|OT_INDEF)) && \ + clecho->p_val.v_i) + +extern struct param *clnotify; +#define notify() (clnotify != NULL && \ + !(clnotify->p_type & (OT_UNDEF|OT_INDEF)) && \ + clnotify->p_val.v_i) + +extern struct param *clmenus; +#define menus() (clmenus != NULL && \ + !(clmenus->p_type & (OT_UNDEF|OT_INDEF)) && \ + clmenus->p_val.v_i) + +extern struct param *clshowtype; +#define showtype() (clshowtype != NULL && \ + !(clshowtype->p_type & (OT_UNDEF|OT_INDEF)) && \ + clshowtype->p_val.v_i) + +extern struct param *clkeeplog; +#define keeplog() (clkeeplog != NULL && \ + !(clkeeplog->p_type & (OT_UNDEF|OT_INDEF)) && \ + clkeeplog->p_val.v_i) + +extern struct param *cllexmodes; +#define lexmodes() (cllexmodes != NULL && \ + !(cllexmodes->p_type & (OT_UNDEF|OT_INDEF)) && \ + cllexmodes->p_val.v_i) + +/* Return a pointer to the name of the logfile, or NULL if not defined. + */ +extern struct param *cllogfile; +#define logfile() \ + ((cllogfile == NULL || (cllogfile->p_type & (OT_UNDEF|OT_INDEF))) ? \ + NULL : cllogfile->p_val.v_s) + +/* Flags and macros for logging control. + */ +extern int cllogmode; /* NOT a *(struct param), see modes.c */ + +#define log_commands() (cllogmode & LOG_COMMANDS) +#define log_background() (cllogmode & LOG_BACKGROUND) +#define log_errors() (cllogmode & LOG_ERRORS) +#define log_trace() (cllogmode & LOG_TRACE) + +#define LOG_COMMANDS 0001 +#define LOG_BACKGROUND 0002 +#define LOG_ERRORS 0004 +#define LOG_TRACE 0010 + +/* CL parameters for Eparam and Ehistory options. + */ +extern int ep_standout, + ep_showall; +extern int eh_standout, + eh_verify, + eh_bol; diff --git a/pkg/cl/clprintf.c b/pkg/cl/clprintf.c new file mode 100644 index 00000000..12c56b09 --- /dev/null +++ b/pkg/cl/clprintf.c @@ -0,0 +1,214 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#define import_stdarg +#include + +#include "config.h" +#include "operand.h" +#include "param.h" +#include "task.h" +#include "errs.h" +#include "proto.h" + +extern void u_doprnt(); + + +/* + * CLPRINTF -- These are just printf's with various implied write files for + * convenience. Also here are other assorted printing utilities. + */ + +/* EPRINTF -- Printf that always writes to the current pseudo-file t_stderr. + */ +void +eprintf (char *fmt, ...) +{ + va_list args; + FILE *eout; + + va_start (args, fmt); + eout = currentask->t_stderr; + u_doprnt (fmt, &args, eout); + va_end (args); + fflush (eout); +} + + +/* OPRINTF -- Printf that always writes to the current pseudo-file t_stdout. + */ +void +oprintf (char *fmt, ...) +{ + va_list args; + FILE *sout; + + va_start (args, fmt); + sout = currentask->t_stdout; + u_doprnt (fmt, &args, sout); + va_end (args); + fflush (sout); +} + + +/* TPRINTF -- Printf that always goes through the pipe out to the currently + * running task. Be a bit more careful here in case a pipe is broken or + * something is going haywire. + */ +void +tprintf (char *fmt, ...) +{ + va_list args; + FILE *out; + + out = currentask->t_out; + if (out == NULL) + cl_error (E_IERR, "no t_out for currentask `%s'", + currentask->t_ltp->lt_lname); + else { + va_start (args, fmt); + u_doprnt (fmt, &args, out); + va_end (args); + fflush (out); + if (ferror (out)) + cl_error (E_UERR|E_P, "pipe write error to `%s'", + currentask->t_ltp->lt_lname); + } +} + + +/* TWRITE -- Write a binary block of data to the current task. + * + * This function is currently not used by anyone. +void +twrite ( + char *buf, + int nbytes +) +{ + FILE *out; + + out = currentask->t_out; + if (out == NULL) { + cl_error (E_IERR, "no t_out for currentask `%s'", + currentask->t_ltp->lt_lname); + } else if (nbytes > 0) { + fwrite (buf, sizeof(*buf), nbytes, out); + fflush (out); + if (ferror (out)) + cl_error (E_UERR|E_P, "pipe write error to `%s'", + currentask->t_ltp->lt_lname); + } +} +*/ + + +/* PRPARAMVAL -- Print the value field of param pp on file fp. + * Give name of file if list, don't do anything if undefinded. + * Do not include a trailing \n. + */ +void +prparamval ( + struct param *pp, + FILE *fp +) +{ + char buf[SZ_LINE]; + + spparval (buf, pp); + fputs (buf, fp); +} + + +/* STRSORT -- Sort a list of pointers to strings. + */ +void +strsort ( + char *list[], /* array of string pointers */ + int nstr /* number of strings */ +) +{ + extern int qstrcmp(); + + qsort ((char *)list, nstr, sizeof(char *), qstrcmp); +} + + +/* QSTRCMP -- String comparison routine (strcmp interface) for STRSRT. + */ +int +qstrcmp ( + char *a, + char *b +) +{ + return (strcmp (*(char **)a, *(char **)b)); +} + + +/* STRTABLE -- Given a list of pointers to strings as input, format and print + * the strings in the form of a nice table on the named output file. Adjust + * the number of columns to fill the page (64 cols) as nearly as possible, + * with at least two spaces between strings. Excessively long strings + * are truncated (adapted from "fmtio/strtbl.x"). + */ +void +strtable ( + FILE *fp, /* output file */ + char *list[], /* array of string pointers */ + int nstr, /* number of strings */ + int first_col, /* where to place table on a line */ + int last_col, + int maxch, /* maximum chars to print from a string */ + int ncol /* desired # of columns (0 to autoscale) */ +) +{ + int row, i, j, nspaces, len, maxlen, colwidth; + int numcol, numrow, str; + char *p; + + /* Find the maximum string length. */ + maxlen = 0; + for (i=1; i <= nstr; i++) + if ((len = strlen (list[i-1])) > maxlen) + maxlen = len; + + /* Cannot be longer than "maxch" characters, if given. */ + if (maxch > 0 && maxch < maxlen) + maxlen = maxch; + + /* Compute the optimum number of columns. */ + if ((numcol = (last_col - first_col + 1) / (maxlen + 2)) < 1) + numcol = 1; + if (ncol > 0 && ncol < numcol) + numcol = ncol; + colwidth = (last_col - first_col + 1) / numcol; + numrow = (nstr + numcol-1) / numcol; + + /* For each row in the table: + */ + for (row=1; row <= numrow; row=row+1) { + for (i=1; i < first_col; i=i+1) /* space to first col */ + putc (' ', fp); + /* For each string in the row: + */ + for (i=1; i <= numcol; i=i+1) { + str = row + (i-1) * numrow; + if (str > nstr) + continue; + p = list[str-1]; /* output string */ + for (j=0; p[j] != '\0' && j < maxlen; j=j+1) + putc (p[j], fp); + if (i < numcol) { /* advance to next col */ + if ((nspaces = colwidth - j) < 2) + nspaces = 2; + for (j=1; j <= nspaces; j=j+1) + putc (' ', fp); + } + } + putc ('\n', fp); /* end of row of table */ + } +} diff --git a/pkg/cl/clsystem.c b/pkg/cl/clsystem.c new file mode 100644 index 00000000..f08e3343 --- /dev/null +++ b/pkg/cl/clsystem.c @@ -0,0 +1,68 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include +#include "errs.h" + + +/* CLSYSTEM -- Run a host system command and try to arrange for its standard + * output and standard error output to go where our t_stdout is going; this + * will let us redirect its output and use it with pipes.. + */ +void +clsystem ( + char *cmd, /* command to be executed */ + FILE *taskout, /* stdout of task */ + FILE *taskerr /* stderr of task */ +) +{ + register char *ip; + register int ch; + char outfile[SZ_PATHNAME], errfile[SZ_PATHNAME]; + FILE *fp; + + /* Ignore null commands. + */ + for (ip=cmd; (*ip == ' ' || *ip == '\t'); ip++) + ; + if (*ip == EOS) + return; + + /* Run command with output redirected into temporary files. + * This is done only if the output is redirected. + */ + outfile[0] = EOS; + errfile[0] = EOS; + + if (taskout && taskout != stdout) + c_mktemp ("tmp$tso", outfile, SZ_PATHNAME); + + if (taskerr == taskout) + strcpy (errfile, outfile); + else if (taskerr && taskerr != stderr) + c_mktemp ("tmp$tse", errfile, SZ_PATHNAME); + + c_oscmd (cmd, "", outfile, errfile); + + /* Copy spooled output, if any, to the error streams of the current + * task. + */ + if (outfile[0] != EOS) + if ((fp = fopen (outfile, "r")) != NULL) { + while ((ch = fgetc (fp)) != EOF) + fputc (ch, taskout); + fclose (fp); + c_delete (outfile); + } + + if (errfile[0] != EOS && taskerr != taskout) + if ((fp = fopen (errfile, "r")) != NULL) { + while ((ch = fgetc (fp)) != EOF) + fputc (ch, taskerr); + fclose (fp); + c_delete (errfile); + } +} diff --git a/pkg/cl/compile.c b/pkg/cl/compile.c new file mode 100644 index 00000000..5550370a --- /dev/null +++ b/pkg/cl/compile.c @@ -0,0 +1,247 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#define import_stdarg +#include + +#include "config.h" +#include "operand.h" +#include "opcodes.h" +#include "mem.h" +#include "errs.h" +#include "task.h" +#include "proto.h" + +/* + * COMPILE -- compile instructions at compile time, compile constants, + * params and misc at runtime on stacks or dictionary. + */ + +memel *dictionary; /* base of dictionary */ +XINT pc; /* program-counter */ +XINT topd, maxd; /* current top and highest d. indices */ + +extern int cldebug; + +/* compile opcode and optional arguments into stack. + * interpret "args" according to what is being compiled. + * if (all goes well during compilation) + * {advance pc, return base addr of new codeentry} + * else + * {leave pc unchanged, return (ERR)} + * TODO: be more sophisticated in guarding against compiling past topcs. + */ + +/*VARARGS1*/ +int +compile (int opcode, ...) +{ + register struct codeentry *cep; + register int status = OK; + va_list argp; + + + if (pc > topcs - 20) { + eprintf ("INTERNAL ERROR: pc/topcs collision: %d/%d\n", pc, topcs); + return (ERR); + } + + va_start (argp, opcode); + + cep = coderef (pc); + cep->c_opcode = opcode; + cep->c_length = 2; /* initial length is opcode+length */ + + switch (opcode) { + + /* all these opcodes have one string argument, at args */ + case ABSARGSET: + case ADDASSIGN: + case ASSIGN: + case CALL: + case CATASSIGN: + case DIVASSIGN: + case GETPIPE: + case GSREDIR: + case INDIRABSSET: + case INSPECT: + case INTRINSIC: + case OSESC: + case MULASSIGN: + case PUSHPARAM: + case SUBASSIGN: + case SWOFF: + case SWON: { + char *sp = va_arg (argp, char *);; + status = comstr (sp, &cep->c_args); + if (status != ERR) + cep->c_length += status; + } + break; + + /* these opcodes use c_args as a pointer to an operand. + * it is copied in-line following the new instruction in the stack. + * further, if type is OT_STRING, compile the string in-line following + * the operand and change o_val.v_s to point to it. + */ + case PUSHCONST: { + register memel *argsaddr; + struct operand *op, *dp; + + op = va_arg (argp, struct operand *); + argsaddr = (memel *) &cep->c_args; + dp = (struct operand *) argsaddr; + *dp = *op; + argsaddr += OPSIZ; + cep->c_length += OPSIZ; + if ((op->o_type & OT_BASIC) == OT_STRING) { + status = comstr (op->o_val.v_s, argsaddr); + if (status != ERR) { + dp->o_val.v_s = (char *) argsaddr; + cep->c_length += status; + } + } + } /* end of case PUSHCONST */ + break; + + /* these opcodes use no arguments */ + case ADD: + case ALLAPPEND: + case ALLREDIR: + case AND: + case APPENDOUT: + case CHSIGN: + case CONCAT: + case DEFAULT: + case DIV: + case END: + case EQ: + case EXEC: + case FSCAN: + case FSCANF: + case GE: + case GT: + case IMMED: + case LE: + case LT: + case MUL: + case NE: + case NOT: + case OR: + case POW: + case PRINT: + case REDIR: + case REDIRIN: + case RETURN: + case SCAN: + case SCANF: + case SUB: + case FIXLANGUAGE: + break; + + /* these opcodes have one simple integer argument; + * rather than put it after the instruction and point c_args there, + * just use c_args itself. + */ + case ADDPIPE: + case BIFF: + case GOTO: + case INDIRPOSSET: + case PUSHINDEX: + case POSARGSET: + case RMPIPES: + cep->c_args = va_arg (argp, int); + cep->c_length++; + break; + + /* SWITCH has one argument which will be supplied after the + * entire switch block has been compiled. + */ + case SWITCH: + cep->c_length ++; + break; + + + /* The CASE statement has a variable number of arguments + * depending on how many different values are set for + * this case block. Just allocate the block and let + * the parser fill in the argument list. + */ + case CASE: + cep->c_length += va_arg (argp, int); + break; + + /* The INDXINCR statment has two integer args. */ + case INDXINCR: { + memel *pargs; + + cep->c_length += 2; + pargs = (memel *) &(cep->c_args); + *pargs++ = va_arg (argp, int); + *pargs = va_arg (argp, int); + break; + } + + default: + cl_error (E_IERR, e_badsw, opcode, "compile()"); + status = ERR; + } + + if (status != ERR) { + XINT oldpc = pc; + pc += cep->c_length; + return (oldpc); + } + return (ERR); +} + + +/* COMSTR -- compile string s into an arbitrary core address loc, which must be + * on an int boundry. + * allow for trailing '\0'. + * return number of whole ints taken up by string else ERR if no room. + * (comdstr() should be used to copy a string into the dictionary) + */ +int +comstr ( + register char *s, + memel *loc +) +{ + register char *to, *from; + + from = (to = (char *)loc); + while ( (*to++ = *s++) ) + ; + return (btoi((memel)to - (memel)from)); +} + +/* copy string s into the dictionary at topd, returning pointer to its + * beginning and incrementing topd properly. + * allow for trailing '\0'. + */ +char * +comdstr (char *s) +{ + char *start; + + start = memneed (btoi (strlen (s) + 1)); + strcpy (start, s); + return (start); +} + +/* concat new string, ns, after existing string, es, in dictionary. + * only works, of course, if memneed() was not called since es was compiled + * originally. + */ +void +catdstr (char *es, char *ns) +{ + int eslen = strlen (es) + 1; + + memneed (btoi (eslen + strlen (ns)) - btoi (eslen)); + strcat (es, ns); +} diff --git a/pkg/cl/config.h b/pkg/cl/config.h new file mode 100644 index 00000000..bd65d57e --- /dev/null +++ b/pkg/cl/config.h @@ -0,0 +1,76 @@ +/* + * CONFIG.H -- Configuration parameters for the IRAF Command Language. + */ + +#define SHARELOG YES /* share logfile with other processes */ + +/* ---------- + * Total size of combined control and operand stack, in ints. + * Note that operands are more than 1 int big, see operand.h for OPSIZ, + * and that tasks certainly are too, see task.h. + * Also, number of INT's dictionary is grown each time topd reaches maxd. + * NOTE: at present, malloc() calls (such as for fio) will fragment the + * dictionary, a fatal error. We have a static sized dictionary until + * this can be fixed. + */ +#define STACKSIZ 128000 +#define DICTSIZE 512000 +#define MEMINCR 1024 + +typedef unsigned long memel; /* type for dictionary, stack, etc. */ + +/* History and command block buffer dimensions. The command block buffer + * must be at least one line in size, and should be large enough to hold + * most interactively entered multiline command blocks. The history buffer + * must be at least as large as the command block buffer. + */ +#define SZ_CMDBLK 2048 +#define SZ_HISTBUF 8192 + +/* ---------- + * char buffers sizes. + */ + +#define MAXMENU 256 /* largest menu than ? can print */ +#define FAKEPARAMLEN (24) /* see newfakeparam(). */ +#define LEN_PKPREFIX 3 /* length of package prefix string */ +#define LEN_PFILENAME 6 /* length of pfilename in uparm */ + +#define NBKG 32 /* max number of active background jobs */ +#define MAXSUBPROC 10 /* max number cached subprocesses */ +#define MAXPIPES 20 /* max pipes in a command */ + +#define forever while (!0) +#define until(x) while (!(x)) + +/* Specify the names of the default cl param file and the startup file. + * All files are assumed to reside in iraf$lib. + * + * CLPROCESS is used as the process name to be used to spawn background + * processes, and to get the directory where the default cl.par file + * may be found. + * CLSTARTUP is executed, as a script, to set up the initial + * evironment defn's, commands, and other stuff. when it starts, the package + * "clpackage" and one task, "cl", are the only things defined. + * used in main(). + * LOGINFILE is the name of the file which, if found in the current directory + * when the cl starts, will also be run as a script, after CLSTARTUP. + * CLLOGOUT is the name of the system logout file, executed when the user + * logs off. + * UPARM is the environment name whose value is used as the directory + * for working copies of param files. see pfileread() and pfilewrite(). + */ + +#define LOGINFILE "login.cl" +#define UPARM "uparm" +#define CLPROCESS "cl.e" +#define CLSTARTUP "clpackage.cl" +#define CLLOGOUT "cllogout.cl" +#define ROOTPACKAGE "language" +#define CLPACKAGE "clpackage" + +/* Indefinite valued numbers. + */ + +#define INDEFSTR undefval /* mode of the param structure. */ +extern char *undefval; diff --git a/pkg/cl/construct.h b/pkg/cl/construct.h new file mode 100644 index 00000000..eeddfdb0 --- /dev/null +++ b/pkg/cl/construct.h @@ -0,0 +1,44 @@ +/* Define variables used during compilation of loop constructs. */ +#define MAX_LOOP 50 +#define N_OPEN_ARR 15 + +/* The LABEL structure is used to store the linked list of LABEL names. + */ +struct label { + char *l_name; /* Pointer to label name. */ + int l_loc; /* Location of label. */ + int l_defined; /* Has actual label been seen. */ + struct label *l_next; /* Pointer to next in list. */ + }; + +/* Pointers to the names of the parameters in a PROCEDURE statement. + * These are used in positional references to params within a script. + */ + +#define MAX_PROC_PARAMS 100 + +extern int nextdest[MAX_LOOP]; /* Destinations for NEXT's */ +extern int brkdest[MAX_LOOP]; /* Destinations for BREAK's */ + +extern int nestlevel; /* Loop nesting level */ +extern int ncaseval; /* Number of cases in switch */ + +extern int n_oarr; /* Number of open array indices */ +extern int i_oarr; /* Current open array index */ + +extern int oarr_beg[N_OPEN_ARR]; /* Open index limits. */ +extern int oarr_end[N_OPEN_ARR]; +extern int oarr_curr[N_OPEN_ARR]; /* Current value for index. */ +extern int imloopset; /* Loop inited at run time? */ +extern int n_indexes; /* Number of indexes on stack. */ + +extern int maybeindex; /* Could last constant be index */ + /* range? */ + +extern struct label *label1; /* Pointer to first top of label list. */ +extern int igoto1; /* Head of list of indirect GOTO's */ + + +extern struct operand *parlist[MAX_PROC_PARAMS]; +extern struct param *last_parm;/* Last parameter before compilation. */ +extern int n_procpar; /* Number of params in proc stmt. */ diff --git a/pkg/cl/debug.c b/pkg/cl/debug.c new file mode 100644 index 00000000..cb721bf8 --- /dev/null +++ b/pkg/cl/debug.c @@ -0,0 +1,457 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "config.h" +#include "operand.h" +#include "mem.h" +#include "grammar.h" +#include "opcodes.h" +#include "param.h" +#include "task.h" +#include "proto.h" + + +/* + * DEBUG -- The various debugging functions. + * + * the D_XXX grammar rules use the d_xxx routines to dump various tables + * for debugging purposes. + * some of these (see setbuiltins()) are done as builtin ltasks, while others + * that show dictionary or stack info are not to avoid the complication of + * having to work around the fact that builtins are really separate tasks. + * all write to stderr. + */ + +extern char *nullstr; +extern int cldebug; +extern int cltrace; +static void dd_f(); + + +/* D_STACK -- Go through the instruction stack, starting at locpc, printing + * what is found until END opcode discovered. If ss > 0, just go through ss + * instructions. Done directly. + */ +void +d_stack ( + register XINT locpc, + int ss +) +{ + register struct codeentry *cep; + int n, opcode, errs = 0; + + do { + cep = coderef (locpc); + opcode = cep->c_opcode; + + if ((n = d_instr (stderr, "", locpc)) <= 0) { + errs++; + locpc += 2; + } else + locpc += n; + + if (ss > 0 && --ss == 0) /* ss > 0 done first! */ + errs = 100; /* simulate end */ + + } while (opcode != END && errs < 10); +} + + +/* D_INSTR -- Decode a single instruction on the output file. The length of + * the instruction in memel is returned as the function value. + */ +int +d_instr ( + FILE *fp, + char *prefix, + register XINT locpc +) +{ + register struct codeentry *cep; + int opcode, extra=0; + + cep = coderef (locpc); + opcode = cep->c_opcode; + + fprintf (fp, "%s%6d+%d: ", prefix, locpc, cep->c_length); + + switch (opcode) { + case ABSARGSET: fprintf (fp, "absargset"); goto string; + case ADDASSIGN: fprintf (fp, "addassign"); goto string; + case ASSIGN: fprintf (fp, "assign"); goto string; + case CALL: fprintf (fp, "call\t"); goto string; + case CATASSIGN: fprintf (fp, "catassign"); goto string; + case DIVASSIGN: fprintf (fp, "divassign"); goto string; + case GSREDIR: fprintf (fp, "gsredir"); goto string; + case INDIRABSSET: fprintf (fp, "indirabsset"); goto string; + case INSPECT: fprintf (fp, "inspect\t"); goto string; + case INTRINSIC: fprintf (fp, "intrinsic"); goto string; + case MULASSIGN: fprintf (fp, "mulassign"); goto string; + case OSESC: fprintf (fp, "os_escape"); goto string; + case PUSHPARAM: fprintf (fp, "pushparam"); goto string; + case SUBASSIGN: fprintf (fp, "subassign"); goto string; + case SWOFF: fprintf (fp, "swoff\t"); goto string; + case SWON: fprintf (fp, "swon"); goto string; +string: + fprintf (fp, "\t%s\n", (char *)&cep->c_args); + break; + + case PUSHCONST: fprintf (fp, "pushconst"); goto op; +op: + { struct operand *op; + + op = (struct operand *) &cep->c_args; + fprintf (fp, "\t"); + if ((op->o_type & OT_BASIC) == OT_STRING) + fprintf (fp, "`"); + fprop (stderr, op); + if ((op->o_type & OT_BASIC) == OT_STRING) + fprintf (fp, "'"); + fprintf (fp, "\n"); + } + break; + + case ADD: fprintf (fp, "add\n"); break; + case ADDPIPE: fprintf (fp, "addpipe\n"); break; + case ALLAPPEND: fprintf (fp, "allappend\n"); break; + case ALLREDIR: fprintf (fp, "allredir\n"); break; + case AND: fprintf (fp, "and\n"); break; + case APPENDOUT: fprintf (fp, "append\n"); break; + case CHSIGN: fprintf (fp, "chsign\n"); break; + case CONCAT: fprintf (fp, "concat\n"); break; + case DEFAULT: fprintf (fp, "default\n"); break; + case DIV: fprintf (fp, "div\n"); break; + case END: fprintf (fp, "end\n"); break; + case EQ: fprintf (fp, "eq\n"); break; + case EXEC: fprintf (fp, "exec\n"); break; + case FSCAN: fprintf (fp, "fscan\n"); break; + case FSCANF: fprintf (fp, "fscanf\n"); break; + case GE: fprintf (fp, "ge\n"); break; + case GETPIPE: fprintf (fp, "getpipe\n"); break; + case GT: fprintf (fp, "gt\n"); break; + case IMMED: fprintf (fp, "immed\n"); break; + case LE: fprintf (fp, "le\n"); break; + case LT: fprintf (fp, "lt\n"); break; + case MUL: fprintf (fp, "mul\n"); break; + case NE: fprintf (fp, "ne\n"); break; + case NOT: fprintf (fp, "not\n"); break; + case OR: fprintf (fp, "or\n"); break; + case POW: fprintf (fp, "pow\n"); break; + case PRINT: fprintf (fp, "print\n"); break; + case REDIR: fprintf (fp, "redir\n"); break; + case REDIRIN: fprintf (fp, "redirin\n"); break; + case RETURN: fprintf (fp, "return\n"); break; + case SCAN: fprintf (fp, "scan\n"); break; + case SCANF: fprintf (fp, "scanf\n"); break; + case SUB: fprintf (fp, "sub\n"); break; + case SWITCH: fprintf (fp, "switch\n"); break; + + case BIFF: fprintf (fp, "biff\t"); goto offset; + case GOTO: fprintf (fp, "goto\t"); goto offset; +offset: + /* Print offset with sign, - or +, in all cases. */ + if ((int)cep->c_args <= 0) + goto oneint; /* pick up sign there */ + else + fprintf (fp, "\t+%d\n", cep->c_args); + break; + + case CASE: fprintf (fp, "case\n"); goto oneint; + case INDIRPOSSET: fprintf (fp, "indirposset"); goto oneint; + case POSARGSET: fprintf (fp, "posargset"); goto oneint; + case RMPIPES: fprintf (fp, "rmpipes\t"); goto oneint; +oneint: + fprintf (fp, "\t%d\n", cep->c_args); + break; + + /* Used for arrays. */ + case PUSHINDEX: fprintf (fp, "pushindex"); goto oneint; + case INDXINCR: fprintf (fp, "indxincr"); + /* Output two jump offsets. */ + fprintf (fp, "\t%d, %d\t", cep->c_args, *(&cep->c_args+1)); + + /* Output array index ranges: {beg, end} * N. */ + { memel *ip = (memel *) &cep->c_args; + int i, n = (int)ip[2]; + + for (ip += 2, i=0; i < n; i++, ip += 2) + fprintf (fp, "%d:%d ", (XINT)*ip, (XINT)(*ip+1)); + fprintf (fp, "\n"); + extra = 2*n + 1; + } + break; + + default: + fprintf (fp, "bad opcode, %d, at pc %d\n", opcode, locpc); + return (-1); + } + + return (cep->c_length + extra); +} + + +/* print neat things about the dictionary and stack. + * done directly. + */ +void +d_d (void) +{ + char *stackaddr = (char *)stack; /* just so we may subtract */ + char *otheraddr; + + eprintf ("\ndictionary indices:\n"); + eprintf ("\tmaxd-1\t%u (%u)\n", maxd-1, dictionary[maxd-1]); + eprintf ("\ttopd\t%u (%u)\n", topd, dictionary[topd]); + eprintf ("\tpachead\t%u (`%s')\n", pachead, + reference (package, pachead)->pk_name); + eprintf ("\tparhead\t%u (`%s')\n", parhead, + reference (pfile, parhead)->pf_ltp->lt_lname); + + eprintf ("\ndictionary pointers (shown as indices)\n"); + eprintf ("\tcurpack\t%u (`%s')\n", dereference (curpack), + curpack->pk_name); + eprintf ("\tdictionary\t%u\n", dictionary); + + eprintf ("\nstack indices\n"); + eprintf ("\ttopcs\t%d\n", topcs); + eprintf ("\ttopos\t%d\n", topos); + eprintf ("\tbasos\t%d\n", basos); + eprintf ("\tpc\t%d\n", pc); + otheraddr = (char *)currentask; + eprintf ("\tcurrentask\t%u (`%s')\n", btoi (otheraddr - stackaddr), + currentask->t_ltp->lt_lname); + otheraddr = (char *)firstask; + eprintf ("\tfirstask\t%u (`%s')\n", btoi (otheraddr - stackaddr), + firstask->t_ltp->lt_lname); +} + + +/* print all loaded pfiles and their params from parhead. + * done as a builtin task. depends on the fact that the fake param file + * has been unlinked from parhead before the builtin is run to avoid showing + * it. see execnewtask(). + */ +void +d_p (void) +{ + register struct pfile *pfp; + register struct param *pp; + register FILE *fp; + int flags; + + fp = currentask->t_stderr; + eprintf ("loaded parameter files -\n"); + for (pfp = reference (pfile, parhead); pfp; pfp = pfp->pf_npf) { + eprintf ("\n\t%s: ", pfp->pf_ltp->lt_lname); + flags = pfp->pf_flags; + if (flags & PF_UPDATE) eprintf ("updated, "); + if (flags & PF_FAKE) eprintf ("fake, "); + if (flags & PF_COPY) eprintf ("copy, "); + if (flags & PF_PSETREF) eprintf ("contains pset pars, "); + eprintf ("\n"); + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) + printparam (pp, fp); + } +} + + +/* print info about the tasks currently on the control stack. + * done as a builtin. no attempt is made to hide the task running for this + * builtin. + */ +void +d_t (void) +{ + register struct task *tp; + int flags; + + eprintf ("stacked tasks (most recent first)\n\n"); + for (tp=currentask; (XINT)tp<(XINT)&stack[STACKSIZ]; tp=next_task(tp)) { + flags = tp->t_flags; + eprintf ("%s:\t", tp->t_ltp->lt_lname); + if (flags & T_SCRIPT) eprintf ("script, "); + if (flags & T_CL) eprintf ("cl, "); + if (flags & T_INTERACTIVE) eprintf ("interactive, "); + if (flags & T_MYOUT) eprintf ("new out, "); + if (flags & T_MYIN) eprintf ("new in, "); + if (flags & T_MYERR) eprintf ("new err, "); + if (flags & T_MYSTDGRAPH) eprintf ("new stdgraph, "); + if (flags & T_MYSTDIMAGE) eprintf ("new stdimage, "); + if (flags & T_MYSTDPLOT) eprintf ("new stdplot, "); + if (flags & T_BUILTIN) + eprintf ("builtin, "); + else + eprintf ("mode = `%s' ", tp->t_modep->p_val.v_s); + eprintf ("\n"); + } +} + + +/* print all loaded packages and their ltasks from pachead. + * builtin. + */ +void +d_l (void) +{ + register struct package *pkp; + register struct ltask *ltp; + int flags; + + eprintf ("loaded packages -\n"); + for (pkp = reference (package,pachead); pkp; pkp = pkp->pk_npk) { + eprintf ("(%u) package `%s':\n", pkp, pkp->pk_name); + for (ltp = pkp->pk_ltp; ltp != NULL; ltp = ltp->lt_nlt) { + flags = ltp->lt_flags; + eprintf ("\t(%u)\t%s: ", ltp, ltp->lt_lname); + if (flags & LT_BUILTIN) + eprintf ("builtin, "); + else + eprintf ("in %s (%d), ", ltp->lt_pname, + ltp->lt_pname); + if (flags & LT_SCRIPT) eprintf ("script, "); + if (!(flags & LT_PFILE)) eprintf ("no pfile, "); + if (flags & LT_STDINB) eprintf ("b_in, "); + if (flags & LT_STDOUTB) eprintf ("b_out, "); + if (flags & LT_INVIS) eprintf ("invisible, "); + eprintf ("\n"); + } + } +} + + +/* D_F -- Determine the number of logical (e.g. dev$null, stropen) and physical + * (host system) file slots available. + */ +void +d_f (void) +{ + dd_f ("logical: ", "dev$null"); + dd_f ("physical: ", "hlib$iraf.h"); +} + +static void +dd_f ( + char *msg, + char *fname +) +{ + FILE *fp[128]; + int fn; + + eprintf (msg); + fn = 0; + while ((fp[fn] = fopen (fname, "r")) != NULL) { + eprintf ("%d,", fileno(fp[fn])); + if (++fn >= 128) + break; + } + eprintf ("\n"); + while (fn > 0) + fclose (fp[--fn]); +} + + +/* enable debugging messages. + * builtins. + */ +void +d_on (void) +{ + cldebug = 1; +} + +/* disable debugging. + */ +void +d_off (void) +{ + cldebug = 0; +} + +/* Enable/disable instruction tracing. + */ +void +d_trace (int value) +{ + cltrace = value; +} + + +/* Dump operand stack until underflow occurs. + */ +void +e_dumpop (void) +{ + struct operand o; + + forever { + o = popop(); + oprop (&o); + } +} + + +/* Format a multiline exec-task message string for debug output. + */ +void +d_fmtmsg ( + FILE *fp, + char *prefix, + char *message, + int width +) +{ + register char *ip, *op, *cp; + char lbuf[SZ_COMMAND], obuf[SZ_COMMAND]; + int len_prefix, nchars; + + len_prefix = strlen (prefix); + + for (ip=message, op=obuf; *ip; ) { + /* Get next message line. */ + for (cp=lbuf, nchars=0; (*cp++ = *ip); ip++, nchars++) { + if (*ip == '\\' && *(ip+1) == '\n') { + *cp++ = 'n'; + nchars += 2; + ip += 2; + break; + } else if (*ip == '\n') { + *(cp-1) = '\\'; + *cp++ = 'n'; + nchars += 2; + ip++; + break; + } + } + *cp++ = '\0'; + + /* Flush output line if it is full. */ + if (len_prefix + op-obuf + nchars > width) { + if (op > obuf) { + *op++ = '\0'; + fprintf (fp, "%s%s\n", prefix, obuf); + op = obuf; + } else { + fprintf (fp, "%s%s\n", prefix, lbuf); + op = obuf; + continue; + } + } + + /* Copy line to output buffer. */ + for (cp=lbuf; *cp; ) + *op++ = *cp++; + } + + /* Flush anything left in output buffer. */ + if (op > obuf) { + *op++ = '\0'; + fprintf (fp, "%s%s\n", prefix, obuf); + } +} diff --git a/pkg/cl/decl.c b/pkg/cl/decl.c new file mode 100644 index 00000000..0cfef489 --- /dev/null +++ b/pkg/cl/decl.c @@ -0,0 +1,878 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "config.h" +#include "clmodes.h" +#include "operand.h" +#include "mem.h" +#include "grammar.h" +#include "opcodes.h" +#include "param.h" +#include "task.h" +#include "errs.h" +#include "construct.h" +#include "ytab.h" /* pick up yacc token #defines */ +#include "proto.h" + + +/* + * DECL -- contains routines used by the parser for referencing parameters + * and for parameter declarations. + */ + +extern int cldebug; + +char *badopt = "Invalid %s option for `%s'."; +char *illegal_opt = "Illegal option for `%s'."; +char *dup_def = "Duplicate definition of `%s' ignored.\n"; + + +/* GETLIMITS -- Get the limits for the n'th index of a parameter. + * Returns ERR if the parameter is not defined, or has fewer than n indexes. + */ +int +getlimits ( + char *pname, + int n, + int *i1, + int *i2 +) +{ + struct param *pp; + char *pk, *t, *p, *f; + int dim; + short *len, *off; + + breakout (pname, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + + /* Paramsrch calls error if it cannot find the param, so we + * needn't check here. + */ + if (!(pp->p_type & PT_ARRAY)) + return (ERR); + + dim = pp->p_val.v_a->a_dim; + if (n >= dim) + return (ERR); + + len = &(pp->p_val.v_a->a_len); + len = len + 2*n; + off = len + 1; + + *i1 = *off; + *i2 = *off + *len - 1; + return (OK); +} + + +/* GET_DIM -- Get the dimensionality of an parameter. If not an array return 0. + */ +int +get_dim (char *pname) +{ + struct param *pp, *lookup_param(); + char *pk, *t, *p, *f; + int dim; + + breakout (pname, &pk, &t, &p, &f); + + /* We can't use paramsrch here because the string we are + * looking for might be a builtin, and paramsrch would fail. + */ + pp = lookup_param (pk, t, p); + + if (pp == NULL || (XINT) pp == ERR) + dim = -1; + else if (!(pp->p_type & PT_ARRAY)) + dim = 0; + else + dim = pp->p_val.v_a->a_dim; + + return (dim); +} + + +/* MAKETYPE -- Set the type of a parameter. + */ +int +maketype (int type, int list) +{ + register int p = -1; + + switch (type) { + case V_BOOL: p = OT_BOOL; + break; + case V_INT: p = OT_INT; + break; + case V_REAL: p = OT_REAL; + break; + case V_STRING: p = OT_STRING; + break; + case V_FILE: p = OT_STRING | PT_FILNAM; + break; + case V_GCUR: p = OT_STRING | PT_GCUR; + break; + case V_IMCUR: p = OT_STRING | PT_IMCUR; + break; + case V_UKEY: p = OT_STRING | PT_UKEY; + break; + case V_PSET: p = OT_STRING | PT_PSET; + break; + case V_STRUCT: p = OT_STRING | PT_STRUCT; + break; + } + + if (list) + p |= PT_LIST; + + return (p); +} + + +/* DO_ARRAYINIT -- Initialize an array from values in a declaration statement. + * This routine must also allocate the array descriptor block. + * + * On entry the control stack contains pointers to operands containing + * the initialization info. Buried beneath this may be the dimension + * and offset information needed for the the array descriptor. The + * dimensionality of the array is passed in nindex, except when + * the user wishes to default the dimension of a one-dimensional + * array to the number of values in the initialization block. + * In that case nindex has been passed as 0. + * + * This program ASSUMES that successive calls to memneed return + * contiguous blocks of memory. This is because we don't know + * the size of the array at first, and we can only allocate the + * space needed to hold the values which have been initialized. + * After we have popped the stack down to array descriptor info + * we may find that some values are not initialized and so we + * may need to allocate more memory. + */ +void +do_arrayinit ( + struct param *pp, + int nval, + int nindex +) +{ + int block1, block2, dim, asiz, asiz2, asiz2x, bastype, i; + int slen; + short *off, *len; + struct arr_desc *parr; + struct operand *o; + union arrhead ar; + + if (cldebug) + eprintf ("do_arrayinit: nindex=%d nval=%d\n", nindex, nval); + bastype = pp->p_type & OT_BASIC; + if (bastype == OT_STRING) + slen = pp->p_lenval; + + dim = nindex; + if (dim == 0) + dim = 1; + asiz = 0; + + /* Allocate an array descriptor. + */ + parr = (struct arr_desc *) memneed (2+dim); + + if (nval > 0) { + asiz = nval; + if (bastype == OT_REAL) + asiz = dtoi (asiz); + block1 = (int) memneed (asiz); + ar.a_i = (int *) block1; + i = nval; + + while (i--) { + o = (struct operand *) pop(); + + switch (bastype) { + + case OT_BOOL: + if (o->o_type != OT_BOOL && o->o_type != OT_INT) { + eprintf ("Invalid type in array initialization.\n"); + *(ar.a_i + i) = INDEFL; + } else + *(ar.a_i + i) = o->o_val.v_i; + break; + + case OT_INT: + if (o->o_type != OT_INT) { + eprintf ("Invalid type in array initialization.\n"); + *(ar.a_i + i) = INDEFL; + } else + *(ar.a_i + i) = o->o_val.v_i; + break; + + case OT_REAL: + switch (o->o_type) { + case OT_INT: + ar.a_r[i] = (double) (o->o_val.v_i); + break; + case OT_REAL: + ar.a_r[i] = o->o_val.v_r; + break; + default: + eprintf ("Invalid type in array initialization.\n"); + ar.a_r[i] = INDEFR; + break; + } + break; + + case OT_STRING: + ar.a_s[i] = o->o_val.v_s; + } /* End of switch. */ + } + } + + /* Get array descriptor info. + */ + if (nindex > 0) { + len = &(parr->a_len); + off = &(parr->a_off); + parr->a_dim = nindex; + + asiz2 = 1; + + i = nindex; + while (i--) { + off[2*i] = pop(); + len[2*i] = pop(); + asiz2 *= len[2*i]; + } + + if (bastype == OT_REAL) + asiz2x = dtoi (asiz2); + else + asiz2x = asiz2; + + if (asiz2x > asiz) { /* Need to allocate more space. */ + block2 = (int) memneed (asiz2x-asiz); + + if (nval == 0) { + block1 = block2; + ar.a_i = (int *) block1; + } + + if (btoi(block2-block1) != asiz) + cl_error (E_IERR, "Memory sync error during array init.\n"); + + /* Initialize undefined elements. + */ + for (i = nval; i < asiz2; i++) + switch (bastype) { + case OT_INT: + case OT_BOOL: + ar.a_i[i] = INDEFL; + break; + case OT_REAL: + ar.a_r[i] = INDEFR; + break; + case OT_STRING: + ar.a_s[i] = memneed (btoi(slen)); + *(ar.a_s[i]) = '\0'; + *(ar.a_s[i] + SZ_FNAME - 1) = '\0'; + } + } else if (nval > asiz2) + /* We just leave the extra values in the dictionary. + * It's not serious enough to make it an error. + */ + eprintf ("Warning: Too many initialization values for `%s'.\n", + pp->p_name); + + } else { /* User didn't give dimensions. */ + parr->a_len = nval; + parr->a_off = 1; + parr->a_dim = 1; + } + + /* At this point initialized string parameters point to the string + * which was returned as an operand. Many array elements could + * point to the same storage. Allocate a constant amount + * of storage for each of the initialized strings and copy + * the initial value into it. + */ + if (bastype == OT_STRING) { + for (i=0; ip_val.v_a = parr; + pp->p_aval = ar; +} + + +/* DO_SCALARINIT -- Initialize a scalar. Mostly copied from ADDPARAM. + */ +void +do_scalarinit ( + struct param *pp, + int inited +) +{ + struct operand *o, undefoper; + extern char *e_invaldef; + int len, bastype; + char *s; + + pp->p_valo.o_type = bastype = pp->p_type & OT_BASIC; + + if (inited) { + o = (struct operand *)pop(); + if (o->o_type == OT_STRING) + s = o->o_val.v_s; + else + s = undefval; + } else { + o = &undefoper; + s = undefval; + undefoper.o_type = OT_STRING; + undefoper.o_val.v_s = undefval; + } + + if (pp->p_type & (PT_LIST|PT_FILNAM|PT_PSET)) { + if (o->o_type != OT_STRING) + cl_error (E_UERR, e_invaldef, pp->p_name); + + pp->p_val.v_s = memneed (btoi(SZ_FNAME)); + pp->p_val.v_s[SZ_FNAME-1] = '\0'; + + if (pvaldefined (pp, s)) { + char *p; + + /* Change a whitespace-only filename into a null string; this + * makes it easier for users to check null filenames in + * scripts. It makes sense anyway since these are invalid + * filenames. + */ + p = s; + while (*p == ' ' || *p == '\t') + p++; + if (*p == '\0' || *p == '\n') + pp->p_val.v_s[0] = '\0'; + else + strncpy (pp->p_val.v_s, s, SZ_FNAME-1); + } else + pp->p_val.v_s[0] = '\0'; + + if (pp->p_type & PT_LIST) + pp->p_listval = memneed (btoi(SZ_LINE)); + + pp->p_valo.o_type = OT_STRING; + + } else if (pp->p_type & (PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY)) { + if (o->o_type != OT_STRING) + cl_error(E_UERR, e_invaldef, pp->p_name); + + len = pp->p_lenval; + pp->p_val.v_s = memneed (btoi (len)); + + if (pvaldefined (pp, s)) + strcpy (pp->p_val.v_s, s); + else + pp->p_val.v_s[0] = '\0'; + + pp->p_val.v_s[len-1] = '\0'; /* the permanent eos */ + pp->p_valo.o_type = OT_STRING; + + } else if (bastype == OT_STRING || (s != NULL && *s == PF_INDIRECT)) { + /* Strings are stored like structs, but are inited from s. + * OT_INDEF/UNDEF refer to p_val. + */ + pp->p_lenval = SZ_LINE; + if (pvaldefined (pp, s)) { + /* String was something conventional. If shorter than SZ_LINE + * call memneed() to allocate sufficient space and copy + * the value into it. + */ + char *news; + + pp->p_valo.o_type = OT_STRING; + len = strlen (s) + 1; /* allow for eos */ + news = memneed (btoi (pp->p_lenval)); + + if (len < pp->p_lenval) { + strcpy (news, s); + s = news; + } else { + pp->p_lenval = len; + pp->p_val.v_s = s; + } + + } else { + /* Either no string was given or it was INDEF/UNDEF. + */ + len = SZ_LINE; + s = memneed (btoi (pp->p_lenval)); + } + + pp->p_val.v_s = s; + pp->p_val.v_s[len-1] = '\0'; /* add the permanent eos */ + pp->p_maxo.o_type = OT_INT; + + } else { + /* Simple non-string type. + */ + if (inited) + pp->p_valo = *o; + else + pp->p_valo.o_type = bastype | OT_UNDEF; + } + + if (cldebug) + eprintf ("do_scalar_init: pp->p_flags=%o\n", pp->p_flags); +} + + +/* SCANFTYPE -- Get file type for file parameter. + */ +int +scanftype ( + struct param *pp, + struct operand *o +) +{ + int type; + char *s; + + if (o->o_type != OT_STRING) + return (ERR); + + type = 0; + s = o->o_val.v_s; + + while (*++s != '\0') + switch (*s) { + case 'b': case 'B': type |= PT_FBIN; break; + case 'n': case 'N': type |= PT_FNOE; break; + case 'r': case 'R': type |= PT_FER; break; + case 't': case 'T': type |= PT_FTXT; break; + case 'w': case 'W': type |= PT_FEW; break; + default: return (ERR); + } + + pp->p_type |= type; + return (OK); +} + + +/* C_SCANMODE -- Get the mode for a parameter. + */ +int +c_scanmode ( + struct param *pp, + struct operand *o +) +{ + if (o->o_type != OT_STRING) + return (ERR); + + pp->p_mode = scanmode (o->o_val.v_s); + return (OK); +} + + +/* SCANLEN -- Get the length for structs and strings. + */ +int +scanlen ( + struct param *pp, + struct operand *o +) +{ + if (o->o_type != OT_INT || + !(pp->p_type & (OT_STRING|PT_LIST|PT_STRUCT))) + return (ERR); + + pp->p_lenval = o->o_val.v_i; + return (OK); +} + + +/* SCANMIN -- Get the minimum for a parameter. + */ +int +scanmin ( + struct param *pp, + struct operand *o +) +{ + int bastype, otype; + + bastype = pp->p_type & OT_BASIC; + otype = o->o_type; + + if (pp->p_type & (OT_BOOL|PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY|PT_PSET)) + return (ERR); + + if (otype == OT_STRING) + if ((bastype == OT_STRING || *(o->o_val.v_s) == PF_INDIRECT)) { + + /* Filename, enumerated string, or indirect reference. + */ + pp->p_mino.o_type = OT_STRING; + pp->p_min.v_s = memneed (btoi(PF_SZMINSTR)); + pp->p_min.v_s[PF_SZMINSTR-1] = '\0'; + strncpy (pp->p_min.v_s, o->o_val.v_s, PF_SZMINSTR-1); + pp->p_flags &= ~P_UMIN; + return (OK); + } + + pushop (o); + opcast (bastype); + pp->p_mino = popop(); + + pp->p_flags &= ~P_UMIN; + return (OK); +} + + +/* SCANENUM -- Get the legal values for an enumerated string an store in the + * min field of the parameter. + */ +int +scanenum ( + register struct param *pp, + register struct operand *o +) +{ + register int bastype; + + bastype = pp->p_type & OT_BASIC; + + if (bastype != OT_STRING || o->o_type != OT_STRING) + return (ERR); + + return (scanmin (pp, o)); +} + + +/* SCANMAX -- Get the maximum for a param. + */ +int +scanmax ( + struct param *pp, + struct operand *o +) +{ + int otype; + + otype = pp->p_type & OT_BASIC; + + if (pp->p_type & (OT_BOOL|PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY|PT_PSET)) + return (ERR); + + if (otype == OT_STRING && o->o_type == OT_STRING) + if (*o->o_val.v_s == '@') { + /* Filename, enumerated string, or indirect reference. + */ + pp->p_maxo.o_type = OT_STRING; + pp->p_max.v_s = memneed (btoi(PF_SZMAXSTR)); + pp->p_max.v_s[PF_SZMAXSTR-1] = '\0'; + strncpy (pp->p_max.v_s, o->o_val.v_s, PF_SZMAXSTR-1); + + pp->p_flags &= ~P_UMAX; + return (OK); + } + + /* Type is equivalent to a simple non-string wrt mins. + */ + pushop (o); + opcast (otype); + pp->p_maxo = popop(); + pp->p_flags &= ~P_UMAX; + return (OK); +} + + +/* PROC_PARAMS -- Check that all of the parameters in the procedure statement + * are now defined. If the mode for these parameters is not declared + * set it to AUTO mode. Also rearrange the parameters so they + * agree with order of definition in the procedure statement. + */ +void +proc_params (int npar) +{ + struct operand *o; + struct param *pp, *fp, *lp, *op, *tp; + + if (npar <= 0) + goto setmodes_; + + fp = lp = NULL; + + while (npar--) { + o = (struct operand *) pop(); + if (o->o_type != OT_STRING) + cl_error (E_UERR,"Invalid parameter in procedure statement.\n"); + + if (npar >= MAX_PROC_PARAMS) + eprintf ( + "Too many parameters: `%s' cannot be used positionally.", + o->o_val.v_s); + + parlist [npar] = o; + + pp = paramfind (parse_pfile, o->o_val.v_s, 0, YES); + if (pp == NULL) + cl_error (E_UERR, "Required parameter `%s' not defined.", + o->o_val.v_s); + + if (pp->p_mode & M_HIDDEN) { + /* This parameter was declared as hidden, but was in the + * procedure statement. Override it with a mode of auto, + * giving the user a warning. + */ + eprintf ("Warning: mode for parameter `%s' overridden.\n", + pp->p_name); + pp->p_mode &= ~M_HIDDEN; + pp->p_mode |= M_AUTO; + } else if (!pp->p_mode) + pp->p_mode = M_AUTO; + + tp = parse_pfile->pf_pp; + op = NULL; + + /* Since we've already found pp, this loop must terminate with a + * break. + */ + while (tp != NULL) { + if (tp == pp) + break; + else { + op = tp; + tp = tp->p_np; + } + } + + /* Take param out of list and add to properly ordered list. + */ + if (op == NULL) + parse_pfile->pf_pp = tp->p_np; + else + op->p_np = tp->p_np; + + if (lp == NULL) + lp = tp; + + tp->p_np = fp; + fp = tp; + } + + lp->p_np = parse_pfile->pf_pp; + parse_pfile->pf_pp = fp; + + while (fp->p_np != NULL) /* Find last parameter. */ + fp = fp->p_np; + parse_pfile->pf_lastpp = fp; + +setmodes_: + /* Insure that all parameters have a mode. The default in a procedure + * script is hidden. + */ + tp = parse_pfile->pf_pp; + while (tp != NULL) { + if (!tp->p_mode) + tp->p_mode = M_HIDDEN; + tp = tp->p_np; + } +} + + +/* INITPARAM -- Get a new parameter and initialize appropriate fields. + */ +struct param * +initparam ( + struct operand *op, + int isparam, + int type, + int list +) +{ + struct param *pp; + extern char *e_lookparm; + int slen; + + pp = paramfind (parse_pfile, op->o_val.v_s, 0, YES); + + if (pp == NULL) { + pp = newparam (parse_pfile); + + slen = strlen(op->o_val.v_s) + 1; + pp->p_name = memneed (btoi(slen)); + strcpy (pp->p_name, op->o_val.v_s); + pp->p_type = maketype (type, list); + + /* Do not initialize the mode of a parameter in a procedure + * script. They will be initialized in proc_params(). + */ + if (parse_state != PARSE_PARAMS) { + if (isparam) + pp->p_mode = M_HIDDEN; + else + pp->p_mode = M_LOCAL; + } + + pp->p_mino.o_type = 0; + pp->p_maxo.o_type = 0; + pp->p_flags |= (P_UMAX|P_UMIN); + pp->p_prompt = undefval; + pp->p_lenval = SZ_FNAME; + + } else if (pp == (struct param *) ERR) { + cl_error (E_UERR, e_lookparm, op->o_val.v_s); + + } else { + pp = NULL; + eprintf (dup_def, op->o_val.v_s); + } + + return (pp); +} + + +/* PROCSCRIPT -- Is this a procedure script? + */ +int +procscript (FILE *fp) +{ + char *p, buf[PF_MAXLIN+1]; + int result; + long fpos; + + result = NO; + fpos = 0L; + + while (fgets (buf, PF_MAXLIN, fp) != NULL) { + for (p = buf; *p == ' ' || *p == '\t'; p++) + ; + if (strncmp (p, "procedure", 9) == 0) { + result = YES; + break; + } else if ((*p == '#') || (*p == '\n')) { + fpos = ftell (fp); + continue; + } else + break; + } + + /* Rewind the file so that the parser sees the procedure statement. + * If NOT a procedure script, rewind the file entirely, as the lexical + * analyzer needs to see the comments to work properly (because of the + * #{ ... #} lexmodes toggle sequences). + */ + if (result) + fseek (fp, fpos, 0); + else + fseek (fp, 0L, 0); + + return (result); +} + + +/* SKIP_TO -- Within a file, skip to the statement beginning with the key. + */ +int +skip_to ( + FILE *fp, + char *key +) +{ + char *p, buf[PF_MAXLIN+1]; + int count, len; + long fpos; + + len = strlen (key); + count = 0; + fpos = 0L; + + while (fgets (buf, PF_MAXLIN, fp) != NULL) { + + count++; + for (p = buf; *p == ' ' || *p == '\t'; p++) + ; + + if (strncmp (p, key, len) == 0) { + /* Seek back to beginning of line. + */ + fseek (fp, fpos, 0L); + return (--count); + } + + fpos = ftell (fp); + } + + return (ERR); +} + + +/* DO_OPTION -- Set parameter attributes which have been explicitly + * defined by the user. + */ +void +do_option ( + struct param *pp, + struct operand *oo, + struct operand *o +) +{ + char *opt; + + /* Determine the options and take appropriate action. + */ + opt = oo->o_val.v_s; + + if (!strcmp (opt, "mode")) { + /* (There is a scanmode() in pfiles.c.) + */ + if (c_scanmode (pp, o) == ERR) + cl_error (E_UERR, badopt, "MODE", pp->p_name); + + } else if (!strcmp (opt, "filetype")) { + if (scanftype (pp, o) == ERR) + cl_error (E_UERR, badopt, "FILETYPE", pp->p_name); + + } else if (!strcmp (opt, "min")) { + if (scanmin (pp, o) == ERR) + cl_error (E_UERR, badopt, "MIN", pp->p_name); + + } else if (!strcmp (opt, "max")) { + if (scanmax (pp, o) == ERR) + cl_error (E_UERR, badopt, "MAX", pp->p_name); + + } else if (!strcmp (opt, "enum")) { + if (scanenum (pp, o) == ERR) + cl_error (E_UERR, badopt, "ENUM", pp->p_name); + + } else if (!strcmp (opt, "len") || !strcmp (opt, "length")) { + if (scanlen (pp, o) == ERR) + cl_error (E_UERR, badopt,"LEN", pp->p_name); + + } else if (!strcmp (opt, "prompt")) { + int slen; + + if (o->o_type != OT_STRING) + cl_error (E_UERR, badopt, "PROMPT", pp->p_name); + + slen = btoi (strlen(o->o_val.v_s) + 1); + pp->p_prompt = memneed (slen); + strcpy (pp->p_prompt, o->o_val.v_s); + + } else + cl_error (E_UERR, illegal_opt, pp->p_name); +} diff --git a/pkg/cl/doc/pset.sys b/pkg/cl/doc/pset.sys new file mode 100644 index 00000000..143d3b2a --- /dev/null +++ b/pkg/cl/doc/pset.sys @@ -0,0 +1,222 @@ +1. Procedures + + ltp = cmdsrch (path) + ltp = ltasksrch (path) + pp = paramsrch (path, &field) + + pfp = pfilesrch (path) + pfp = pfileload (ltp) + pfileupdate (pfp) + pfilemerge (pfp, oldpfile) + pfp = pfileread (pfilename) + pfilewrite (pfp, pfilename) + + +2. Pseudocode + + +# PFILESRCH -- Given a pfile name or the name of an ltask which has a pfile, +# allocate a pfile descriptor and read the pfile into that descriptor. + +pfp procedure pfilesrch (path) + +begin + if (path is a filename) + return (pfp = pfileread (fname)) + else { + ltp = ltasksrch (path) + return (pfp = pfileload (ltp)) + } +end + + +# PFILELOAD -- Load the pfile for an ltask, given its descriptor ltp. + +pfp procedure pfileload (ltp) + +begin + pfp = NULL + + if (ltp references a pset task) { + Descend the control stack task-list and examine the pset of + each task to locate the most recently executed task which + references this pset task. The value of the pset parameter + for that task determines which pfile to use. + + if (pset_param_value is a filename (.par or .cl extn)) + return (pfp = pfileread (fname)) + else if (pset_param_value is an ltaskname) + ltp = ltask descriptor of that task + else + do nothing - use pset of pset-task on ltp + } + + make usr_pfile name = uparm$pkgltask.par + if (pfileload already called for this task) + return (pfp = pfileread (usr_pfile)) + + get finfo of usr_pfile + get filename, finfo of pkg_pfile + (check for .par, and if not found, use .cl) + + if (usr pfile exists and has a nonzero extent) { + if (usr pfile is older than pkg_pfile) { + # Merge old usr_pfile into pkg_pfile, update usr_pfile. + pfp = pfileread (pkg_pfile) + pfp->pfilename = usr_pfile + pfilemerge (pfp, usr_pfile) + } + } else if (uparm exists and learning is enabled) { + # Make user copy of pkg pfile. + pfp = pfileread (pkg_pfile) + pfp->pfilename = usr_pfile + } else + return (pfileread (pkg_pfile)) + + set bit in ltask descriptor so that we don't do this again + (must be cleared if pfile is unlearned) +end + + +# PFILEUPDATE -- Update a parameter set in the pfile from which it was +# originally read. + +procedure pfileupdate (pfp) + +begin + if (fake pset or pset has not been modified) + return + else if (pset is cl.par) + return + + call pfilewrite (pfp, pfp->pfilename) +end + + +# PFILEMERGE -- Merge the parameter values from the named pfile into the +# given parameter set. + +procedure pfilemerge (pfp, pfile) + +begin + mark topd + ofp = pfileread (pfile) + + for (each parameter in ofp) { + find associated parameter in pfp + if (param not found) + warn user + else if (illegal datatype conversion) + warn user + else + set value of parameter in pfp version + } + + restore topd +end + + +# PFILEREAD -- Allocate a pfile descriptor and read the named pfile into it. +# The input pfile may be either a parameter file or a CL procedure script. + +pfp procedure pfileread (pfilename) + +begin + allocate pfile descriptor + + open pfile + + if (pfilename has a .cl extension) + parse pfile into pfile descriptor + else + scan pfile into pfile descriptor + + close pfile +end + + +# PFILEWRITE -- Write the parameter set in the pfile descriptor to the +# named file. Any existing file is overwritten. + +procedure pfilewrite (pfp, pfilename) + +begin + if (pfilename does not have .par extension) + add or modify extension to .par + + delete old pfile + disable interrupts + + open new pfile + write parameters + close pfile + + reenable interrupts +end + + +-------------- +path procedure paramsrch (path, ¶m) + +begin + parse arg list + + # Get field name. + if (argc > 1 && last arg is a p_field reference) { + map field name to field code + decrement arg count + } + + # Get parameter name. + if (argc < 1) + error + else { + last arg is param name + decrement arg count + } + + if (no args left) { + search for the parameter via the usual param search path, + i.e., task, package, cl. + } else { + compose path to ltask + call ltasksrch to find task + readin pfile for task + search pfilelist for named parameter + } + + return p_name field code + return (pp) +end + + +ltask procedure ltasksrch (path) + +begin + parse arg list + + # Find defined task. + search task list for first arg, + via circular search of the loaded packages + while (arg is a package) + search pkg task list for next arg + + # Deal with pset task references. + while (arg list is not exhausted) { + readin pfile for task + search pfilelist for next arg + if (param found and it is a pset parameter) { + if (value is null) + search pkg list for task of the same name + else if (value is a taskname) + search pkg list for named task + else if (value is a pfilename) { + setup dummy ltask struct at topd + readin pfile, attach to ltask + } + } else + break + } + + return (ltp pointer to ltask descriptor) +end diff --git a/pkg/cl/edcap.c b/pkg/cl/edcap.c new file mode 100644 index 00000000..b4800754 --- /dev/null +++ b/pkg/cl/edcap.c @@ -0,0 +1,392 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_stdio +#define import_libc +#define import_ctype +#define import_fset +#define import_spp +#include + +#include "config.h" +#include "operand.h" +#include "param.h" +#include "task.h" +#include "eparam.h" +#include "proto.h" + + +#define COLWIDTH 40 /* column width for showhelp */ + + +/*------------------------------------------------------------------------- + * EDCAP.C -- Tools to support the edcap utility, used to define the input + * language of screen editors. + * + * External procedures: + * edtinit initialize the editor database and terminal + * edtexit terminate edit mode (may send output to terminal) + * host_editor return host command used to call the named editor + * what_cmd convert escape sequence into editor command + * show_editorhelp print a list of editor keystrokes + * + * Internal procedures: + * get_editor open and scan the EDCAP file + * cmd_match search the editor command list for an escape sequence + * map_escapes map encoded escape sequence from EDCAP file + * + *------------------------------------------------------------------------- + */ + +static char ed_editorcmd[SZ_LINE+1]; +static void map_escapes(); + + +/* EDTINIT -- Initialize the editor. + */ +void +edtinit (void) +{ + register int i; + char editor[SZ_FNAME]; /* the name of the editor */ + + /* See if the current editor is the one to use. If not, get the + * editor.ed definitions. + */ + if (c_envgets ("editor", editor, SZ_FNAME) > 0) + if (strcmp (editor, command[EDITOR_ID].keystroke) != 0) + get_editor (editor); + + /* Count the number of editor commands. + */ + numcommands = FIRST_CMD; + for (i=FIRST_CMD; command[i].cmd < NOMORE_COMMANDS; i++) + numcommands++; + + /* Send the initial edit sequence (to enable keypad, if any). + */ + if (*(command[EDIT_INIT].escape) != '\0') + printf ("%s",command[EDIT_INIT].escape); + + /* Enable transmission of the screen repaint sequence, to be returned + * by the terminal driver if the process is suspended and later + * resumed while in raw mode. + */ + for (i=FIRST_CMD; command[i].cmd < NOMORE_COMMANDS; i++) + if (command[i].cmd == REPAINT && strlen(command[i].escape)==1) + c_fseti ((XINT)STDOUT, F_SETREDRAW, command[i].escape[0]); +} + + +/* EDTEXIT -- Terminate the editor. Send an escape sequence to the terminal + * if necessary. + */ +void +edtexit (void) +{ + c_fseti ((XINT)STDOUT, F_SETREDRAW, 0); + if (*(command[EDIT_TERM].escape) != '\0') + printf ("%s",command[EDIT_TERM].escape); +} + + +/* HOST_EDITOR -- Return a pointer to the command string to be sent to the + * host system to run an editor, given the user name for the editor. + */ +char * +host_editor (char *editor) +{ + get_editor (editor); + return (ed_editorcmd); +} + + +/* GET_EDITOR -- Redefine the editor keystrokes from the editor.ed file. + * Search for that file first in the users home directory. If not found + * there, look in the standard device directory. + */ +void +get_editor ( + char *editor /* the name of the editor */ +) +{ + FILE *fp; /* pointer to the editor.ed file */ + char string[SZ_LINE];/* an edcap string from the .ed file */ + char label[SZ_LINE]; /* the key-sequence label (keyword) */ + char escape[SZ_LINE];/* the escape sequence in c octal */ + char name[SZ_LINE]; /* the keystroke name, for HELP */ + char fname[SZ_PATHNAME]; + int i, num, n; + + /* Search the directories for the edcap file editor.ed. + */ + sprintf (fname, "home$%s.ed", editor); + fp = fopen (fname, "r"); + + if (fp == NULL) { + sprintf (fname, "dev$%s.ed", editor); + fp = fopen (fname, "r"); + + if (fp == NULL) { + eprintf ("cannot find edcap file for `%s'\n", editor); + eprintf ("editor language defaults to `%s'\n", + command[EDITOR_ID].keystroke); + return; + } + } + + /* Parse the edcap file and initialize the command list and the host + * editor command string (default `irafvi', `irafemacs', etc.). + */ + sprintf (ed_editorcmd, "iraf%s", editor); + num = 0; + + while (fgets (string, SZ_LINE, fp) != NULL) { + /* Check for the EDITOR_CMD field, the command to be sent to the + * host system to run the editor. This is a special case since + * the edcap format does not support anything but keystrokes. + * A termcap format file should have been used for this + * database, rather than defining a new format file, then this + * would not have been necessary. + */ + if (strncmp (string, "EDITOR_CMD", 10) == 0) { + char *ip, *op; + char delim; + int isformat; + + /* Extract the optionally quoted host command format string. + * This is either the editor command name (prefix), e.g., + * "irafemacs", or an SPRINTF format string containing a %s + * where the filename(s) are to go. + */ + for (ip=string+10; isspace(*ip); ip++) + ; + delim = (*ip == '"' || *ip == '\'') ? *ip++ : 0; + for (op=ed_editorcmd, isformat=NO; (*op = *ip++); op++) { + if ((delim && *op == delim) || (!delim && isspace(*op))) + break; + else if (*op == '%' && *ip == 's') + isformat++; + } + + /* If the command string did not contain an embedded %s to + * indicate where the file names(s) are to go, add one at + * the end, i.e., "... %s". + */ + if (!isformat) { + *op++ = ' '; + *op++ = '%'; + *op++ = 's'; + } + + *op = EOS; + continue; + } + + /* Process a normal editor command into the command table. + * Each line must contain three tokens, the internal command + * name, the terminal escape sequence, and the keystroke name. + */ + n = sscanf (string, "%s %s %s", label, escape, name); + + if (n == 3) { + /* Determine which legitimate editor command this is. + */ + for (i=0; i < NUM_COMMANDS; i++) + if (strcmp (label, cmdnames[i]) == 0) + break; + + /* Stuff the command into the static command buffer. + */ + if (i < NUM_COMMANDS) { + command[num].cmd = i; + map_escapes (escape, label); + strncpy (command[num].escape, label, SZ_ESCAPE); + strncpy (command[num].keystroke, name, SZ_KEYSTROKE); + num++; + } + } + } + + /* Make sure the command buffer terminates here. + */ + command[num].cmd = NOMORE_COMMANDS; + strcpy (command[num].escape, ""); + strcpy (command[num].keystroke, " "); + + strncpy (command[EDITOR_ID].keystroke, editor, SZ_KEYSTROKE); + fclose (fp); +} + + +/* MAP_ESCAPES -- Take an ASCII string which may have escape sequences + * encoded as octal (\nnn). Copy the string to the output, replacing + * the encoded values with the binary character value. The output + * string may be the same as the input string. + * + * Control codes may be represented in the input in any of the following ways: + * + * ^X control-X + * \[befnrt] backspace, escape, formfeed, newline, return, tab + * \nnn octal constant + * \^ the character ^ + * \\ the character \ + * + * Ordinary characters are copied to the output. + */ +static void +map_escapes ( + char *input, /* pointer into input string */ + char *output /* pointer into output string */ +) +{ + static char *echars = "befnrt"; + static char *ecodes = "\b\033\f\n\r\t"; + register char *ip = input; + register char *op = output; + register int n; + char *index(); + + while (*ip != '\0') { + if (*ip == '\\') { + switch (*++ip) { + case 'b': case 'e': case 'f': + case 'n': case 'r': case 't': + *op++ = ecodes[index(echars,*ip++)-echars]; + break; + default: + if (isdigit (*ip)) { + for (n=0; isdigit(*ip) != 0; ip++) + n = n * 8 + (*ip - '0'); + *op++ = n; + } else + *op++ = *ip++; + } + } else if (*ip == '^') { + ip++; + *op++ = (*ip++ % 040); + } else + *op++ = *ip++; + } + + *op = '\0'; +} + + +/* WHAT_CMD -- Determine which editing command has been sent. Such commands + * must begin with a non-printable character. Return the command number or + * zero if unrecognized. We are called with the first character of the + * command (some control code). Additional keystrokes are read from the + * standard input until an editor command is recognized. + */ +int +what_cmd ( + char first_char /* the first unprintable character */ +) +{ + register int nchars, k; + char cmd_string[9]; + char *cmd; + + cmd = cmd_string; + *cmd = first_char; + + /* Loop until we get an exact match or until we get no match. + * A character is read from the standard input in each pass + * through the loop. + */ + for (nchars=1; nchars < 9; nchars++) + if ((k = cmd_match (cmd_string, nchars)) < 0) + return (0); + else if (nchars == strlen (command[k].escape)) + return (command[k].cmd); + else + *(++cmd) = fgetc(stdin); + + return (0); +} + + +/* CMD_MATCH -- Scan the first nchars of the available commands to see if + * any match the command string. Return -1 if the command string does not + * match any editor escape sequence, else return the index of the first + * command code matched. + */ +int +cmd_match ( + char *cstring, /* command string */ + int nchars /* nchars to compare */ +) +{ + int k; + + for (k=FIRST_CMD; k <= numcommands; k++) + if (strncmp (cstring, command[k].escape, nchars) == 0) + return (k); + + return (-1); +} + + +/* SHOW_EDITORHELP -- Display the edit commands and their keystroke + * equivalences. + */ +void +show_editorhelp (void) +{ + char sbuf[MAX_COMMANDS*COLWIDTH]; + char *strp[MAX_COMMANDS]; + int center, maxcols, firstcol, lastcol, nstrs, i; + int save_raw; + + + maxcols = c_envgeti ("ttyncols"); + center = maxcols / 2; + + /* Disable raw mode output so that output processing will be enabled, + * e.g., to map newlines into crlfs. + */ + save_raw = c_fstati ((XINT)STDOUT, F_RAW); + c_fseti ((XINT)STDOUT, F_RAW, NO); + + /* Format the help strings for the individual keystrokes. + */ + for (i=FIRST_CMD, nstrs=0; i <= numcommands; i++) { + if (*(command[i].escape) != '\0') { + strp[nstrs] = &sbuf[nstrs*COLWIDTH]; + sprintf (strp[nstrs], "%8w%-10.10s = %-11.11s%2w", + cmdnames[command[i].cmd], command[i].keystroke); + nstrs++; + } + } + + e_clear(); + e_goto (center - 7, 1); + e_putline ("EDIT COMMANDS ("); + e_putline (command[EDITOR_ID].keystroke); + e_putline (")\n\n"); + + /* Sort and output the string table. + */ + if (nstrs) { + strsort (strp, nstrs); + i = strlen (strp[0]); + firstcol = center - i - 2; + lastcol = center + i + 2; + strtable (stdout, strp, nstrs, firstcol, lastcol, COLWIDTH, 2); + } + + e_putline ("\n"); + e_ctrl ("so"); + e_putline ("[hit any key to continue]"); + e_ctrl ("se"); + + /* Restore raw mode. + */ + c_fseti ((XINT)STDOUT, F_RAW, save_raw); + + fflush (stdout); + + /* Pause. */ + fgetc (stdin); +} diff --git a/pkg/cl/eparam.c b/pkg/cl/eparam.c new file mode 100644 index 00000000..829712b5 --- /dev/null +++ b/pkg/cl/eparam.c @@ -0,0 +1,2182 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_stdio +#define import_libc +#define import_error +#define import_ctype +#define import_ttset +#define import_fset +#define import_spp +#include + +#include "config.h" +#include "mem.h" +#include "operand.h" +#include "errs.h" +#include "param.h" +#include "grammar.h" +#include "task.h" +#include "eparam.h" +#include "proto.h" + + +/* + * EPARAM -- Screen editor for parameter files. + * + * epset (pset) # edit any pset by name + * eparam (cx, &update, &cmd, &newpset) # edit incore pfile struct + * + * EHIST -- Screen editor for the history list. + * + * edit_history_directive (raw_cmd, new_cmd) + * + * Both of these primary functions use the following internal editing + * functions (and many more). These use EDCAP to describe the editor + * language to be used, and TERMCAP to describe the terminal to be driven. + * + * e_ttyinit enter edit mode + * e_ttyexit exit edit mode + * + * editstring screen editor for a string + * + * e_clear clear the screen + * e_clrline clear the current line + * e_ctrl send control sequence to the terminal + * e_display display text at addressed coordinates + * e_goto move cursor + * e_putline put a line to terminal with escape translation + * + * E_TTYINIT must be called to initialize the editor database and put the + * terminal into edit mode before calling any of these functions. + */ + +extern int cldebug; +static char dbg[SZ_LINE]; /* for formatting msgs */ +#define E_DEBUG(str) e_display(str,cmdline,1) /* debug msg on last line */ + +struct param *parmlist[G_MAXPARAM]; /* assoc. keyword with param */ +static struct pfile *pfilep; +static int keylines[G_MAXPARAM]; /* starting linenos of each keyword */ +static int firstelement[G_MAXPARAM]; /* first element on row for array */ +static int topkeys[G_MAXPAGES]; /* array of topkeys for each page */ + +static int maxpage; /* maximum page number */ +static int cmdline; /* last line on screen */ +static int maxcol; /* last column on screen */ +static int line, topline, botline; /* current, top, bottom lines */ +static int col, startcol, nextcol; /* current, first, last columns */ +static XINT tty_fd, tty; /* define the terminal globally */ +static int botkeyline, nextline, /* various global variables for */ + keyid, numkeys, topkey, /* keeping track of lines and keys */ + botkey, nextkey; +static int error_displayed = 0; /* flag for error messages */ + +static int standout; /* flag for turning standout mode off */ +static int e_ucasein=NO,e_ucaseout=NO; /* tt case flags for raw mode i/o */ +static int ep_status = OK; /* OK=normal exit, ERR=ctrl/c exit */ +static int ep_filemode = NO; /* editing a file not a task */ +static int ep_nextcmd; /* next eparam command upon exit */ +static int ep_update; /* update pfile upon exit */ +static char e_nextpset[SZ_FNAME+1]; /* next pset to be edited */ +static struct ep_context *e_cx; /* current context */ + +/* These global variables are reset by parse_clmodes() in modes.c whenever the + * appropriate CL parameter is changed. + */ +int ep_standout = YES; /* eparam default for standout */ +int ep_showall = NO; /* display all params, incl. hiddens */ +int eh_standout = YES; /* ehist default for standout */ +int eh_bol = NO; /* start ehist at beginning of line */ +int eh_verify = NO; /* use ehist with history meta-chars */ + +char *e_tonextword(), *e_toprevword(), *index(); + + +/* EPSET -- Edit a parameter set. Once in the parameter set editor, editor + * colon commands may be used to edit any other parameter set, to save psets + * in pfiles, load psets from pfiles, and so on. ERR is returned if the user + * wants to quit altogether, e.g., when epset is called in a loop. + */ +int +epset ( + char *pset /* ltaskname or pfilename */ +) +{ + struct ep_context context[20], *cx; + char newpset[SZ_FNAME+1]; + char runcmd[SZ_LINE+1]; + int update, cmd; + + cx = context; + cx->e_mpfp = NULL; + strcpy (cx->e_pset, pset); + + while (cx >= context) { + /* Open the pfile to be edited. */ + if (cx->e_mpfp == NULL) { + cx->e_topd = topd; + cx->e_mpfp = pfilesrch (cx->e_pset); + cx->e_cpfp = pfilecopy (cx->e_mpfp); + cx->e_init = YES; + } + + /* Edit pset. If ERR is returned exit immediately without + * updating any pfiles, returning ERR to our caller. + */ + if (eparam (cx, &update, &cmd, newpset) == ERR) { + for (; cx >= context; --cx) { + pfileunlink (cx->e_cpfp); + if (dereference (cx->e_mpfp) >= cx->e_topd) + pfileunlink (cx->e_mpfp); + topd = cx->e_topd; + } + return (ERR); + } + + /* If we are done with this pfile (not descending into a pset) + * update the pfile on disk and free memory. + */ + if (cmd != EP_DESCEND) { + if (update) { + pfcopyback (cx->e_cpfp); + pfileupdate (cx->e_mpfp); + } else + pfileunlink (cx->e_cpfp); + + if (dereference (cx->e_mpfp) >= cx->e_topd) + pfileunlink (cx->e_mpfp); + cx->e_mpfp = NULL; + cx->e_cpfp = NULL; + topd = cx->e_topd; + } + + /* Decide what to do next. */ + switch (cmd) { + case EP_EOF: /* pop context */ + --cx; + break; + case EP_EDIT: /* edit a new pfile */ + strcpy (cx->e_pset, newpset); + break; + case EP_DESCEND: /* push context & edit */ + cx++; + cx->e_mpfp = NULL; + strcpy (cx->e_pset, newpset); + break; + case EP_RUN: /* run the task */ + sprintf (runcmd, "%s (mode='h')\n", newpset); + c_ungetline (fileno (prevtask->t_in), runcmd); + return (OK); + default: + eprintf ("eparam: unrecognized command\n"); + --cx; + break; + } + } + + return (OK); +} + + +/* EPARAM -- Edit a parameter set which has already been loaded into a + * pfile structure. Most editor colon commands will cause an exit, + * returning the user command to the caller, e.g., to edit a new pset or + * quit. The context of the editor is saved upon exit in the context + * structure, allowing the editor to be reentered at the same point + * on the old pset. + */ +int +eparam ( + struct ep_context *cx, /* eparam editor context */ + int *update, /* update pset upon exit */ + int *nextcmd, /* receives next command */ + char *nextpset /* receives next pset name */ +) +{ + char string[G_MAXSTRING]; + + pfilep = cx->e_cpfp; /* save in global variables */ + e_cx = cx; + + standout = ep_standout; /* set standout value */ + e_ttyinit(); /* initialize the terminal */ + edtinit(); /* and initialize the editor */ + + /* When we are called to edit a file, the ltask ptr is NULL. + */ + if ((ep_filemode = (pfilep->pf_ltp == NULL))) + topline--; /* room for one more param line */ + + numkeys = e_makelist (pfilep); /* initialize parameter list */ + if (numkeys < 1) /* nothing to edit */ + goto exit; + + ep_status = OK; + ep_nextcmd = EP_EOF; /* default if no :cmd */ + ep_update = YES; /* default unless cleared */ + + if (cx->e_init) { + /* New pfile: start at the top. */ + topkey = 1; + line = topline; + col = startcol; + nextkey = topkey; + nextline = topline; + } else { + /* Reentering an old pfile: start where we left off. */ + topkey = cx->e_topkey; + line = cx->e_line; + col = cx->e_col; + nextkey = cx->e_nextkey; + nextline = cx->e_nextline; + } + + if (parmlist[topkey]->p_type & PT_ARRAY) /* add line for array */ + line++, nextline++; + + e_repaint(); + + /* Main EPARAM loop. + */ + while (nextline != cmdline) { + keyid = nextkey; + line = nextline; + col = startcol; + + e_goto (col, line); + fflush (stdout); + + /* Encode value string and call the string editor to give the + * user a chance to edit it. + */ + e_encode_vstring (parmlist[keyid], string); + + if (editstring (string, YES) > 0) + e_check_vals (string); + + e_scrollit(); + } +exit: + /* Save our context in case we reenter this pfile. */ + cx->e_topkey = topkey; + cx->e_line = line; + cx->e_col = col; + cx->e_nextkey = keyid; + cx->e_nextline = line; + cx->e_init = 0; + + e_goto (1, cmdline); + e_clrline(); + + edtexit(); + e_ttyexit(); + + *update = ep_update; + *nextcmd = ep_nextcmd; + strcpy (nextpset, e_nextpset); + + return (ep_status); +} + + +/* E_MAKELIST -- Make a list of pointers to each parameter structure to aid + * speedy access. Return the number of parameters in the list. For a + * multiline prompt environment, we need a table of pointers to the firstline + * of each keyword. + */ +int +e_makelist ( + struct pfile *pfileptr +) +{ + register struct param *pp; + register char c, *p; + int numnew; /* number of newlines */ + int totlines; /* count of current total lines */ + + topkeys[0] = 1; + totlines = 0; + maxpage = 0; + + /* Scan the parameter list, adding each parameter to the EPARAM + * list. Hidden parameters are skipped if ep_showall=no (in epinit). + */ + for (pp = pfileptr->pf_pp, numkeys = 0; pp != NULL; pp = pp->p_np) { + + if ((pp->p_mode & M_HIDDEN) && (ep_showall == NO)) + continue; + + numkeys++; + parmlist[numkeys] = pp; + + /* Count the number of newlines in the prompt, add to keylines. + */ + numnew = 0; + p = pp->p_prompt; + + while ((c = *p) != '\0') { + if (c == '\n') + numnew++; + p++; + } + + totlines += numnew + 1; + keylines[numkeys] = numnew + 1; + firstelement[numkeys] = 1; + + if (pp->p_type & PT_ARRAY) { + int numonrow, nextelement; + int dim, d, alines; + short *plen, len, flen; + + keylines[numkeys]++; /* 1 extra line for arrays */ + totlines++; + totlines = e_testtop (totlines, numnew+1+1); + + dim = pp->p_val.v_a->a_dim; + plen = &(pp->p_val.v_a->a_len); + flen = *plen; /* first length */ + alines = (flen - 1) / MAX_ON_ROW + 1; + numonrow = (flen > MAX_ON_ROW) ? MAX_ON_ROW : flen; + + for (d=1; d < dim; d++) { + len = *(plen + 2*d); + alines *= len; + } + + nextelement = 1; + for (d=1, numkeys++; d < alines; d++, numkeys++) { + parmlist[numkeys] = pp; + keylines[numkeys] = 1; + + nextelement += numonrow; + firstelement[numkeys] = nextelement; + + totlines++; + totlines = e_testtop (totlines, numnew+1+1+d); + } + + --numkeys; + + } else { + totlines = e_testtop (totlines, numnew+1); + } + } + + if (cldebug) { + int i; + for (i=1; i <= numkeys; i++) { + sprintf (dbg, "parmlist: %d %d %d ", + parmlist[i], keylines[i], firstelement[i]); + E_DEBUG (dbg); + } + sprintf (dbg, " maxpage = %d ", maxpage); + E_DEBUG (dbg); + for (i=1; i<= maxpage; i++) { + sprintf (dbg, "topkeys : %d ", topkeys[i]); + E_DEBUG (dbg); + } + sprintf (dbg, "numkeys = %d ", numkeys); + E_DEBUG (dbg); + } + + return (numkeys); +} + + +/* E_TESTTOP -- Check to see if we have filled up a screen and if so, + * start a new page. + */ +int +e_testtop ( + int cur, /* current line count on screen */ + int new /* new count, returned if new page */ +) +{ + if (cur > (botline - topline + 1)) { + topkeys[++maxpage] = numkeys; + return (new); + } else + return (cur); +} + + +/* E_REPAINT -- Repaint the current screen. + */ +void +e_repaint (void) +{ + static char *static_prompt = "--------- parameter array ---------"; + char outbuf[MAXPROMPT]; + int i, keylin, ll, cc; + char *p; + + /* More keys than can fit on the screen? + */ + keylin = topline; + for (i=topkey; i <= numkeys && (keylin+keylines[i] <= (botline+1)); ) { + botkeyline = keylin; + keylin += keylines[i++]; + } + + botkey = i - 1; + if (parmlist[botkey]->p_type & PT_ARRAY) + botkeyline += keylines[botkey] - 1; + + e_pheader (pfilep, cmdline, maxcol); + + ll = line; + cc = col; + line = topline; + col = startcol; + + for (keyid=topkey; keyid <= botkey; keyid++) { + + if ((parmlist[keyid]->p_type & PT_ARRAY) && + (firstelement[keyid] == 1)) { + + /* Print the array parameter name. If hidden, enclose it in () + * as in lparam. + */ + if (parmlist[keyid]->p_mode & M_HIDDEN) + sprintf (outbuf, "(%-7.7s) ", parmlist[keyid]->p_name); + else + sprintf (outbuf, "%-8.8s ", parmlist[keyid]->p_name); + e_display (outbuf, line, 1); + + /* Display the prompt over the values, to allow user to + * label columns (if desired). + */ + p = parmlist[keyid]->p_prompt; + if (p == NULL || *p == NULL) + p = static_prompt; + + /* e_indent_prompt (p, promptbuf, startcol); */ + e_display (p, line, startcol); + + line += keylines[keyid] - 1; + e_drawkey(); + line++; + + } else { + e_drawkey(); + line += keylines[keyid]; + } + + fflush (stdout); + } + + e_moreflag (topkey); + + keyid = topkey; + e_goto (cc, ll); + line = ll; + col = cc; +} + + +/* E_PHEADER -- Print the EPARAM form header. + */ +void +e_pheader ( + struct pfile *pfp, /* pfile pointer */ + int cmdline, /* terminal command line number */ + int maxcol /* max cols on a line */ +) +{ + static char *logo = " I R A F "; + static char *title= "Image Reduction and Analysis Facility"; + char string[SZ_LINE+1]; + int i, col; + + e_clear(); + + /* Print logo and title lines. + */ + col = (maxcol - strlen(logo)) / 2; + e_ctrl ("so"); + e_goto (col, 1); + e_putline (logo); + + col = (maxcol - strlen(title)) / 2; + e_ctrl ("se"); + e_ctrl ("us"); + e_goto (col, 2); + e_putline (title); + + /* Identify object being edited. + */ + e_goto (1, 3); + e_ctrl ("ue"); + if (ep_filemode) { + sprintf (string, "PARFILE = %s\r\n", pfp->pf_pfilename); + e_putline (string); + } else { + struct ltask *ltp = pfp->pf_ltp; + sprintf (string, "PACKAGE = %s\r\n", ltp->lt_pkp->pk_name); + e_putline (string); + sprintf (string, " TASK = %s\r\n", ltp->lt_lname); + e_putline (string); + } + + for (col=0; col < maxcol; col++) + string[col] = ' '; + string[maxcol] = '\0'; + e_ctrl ("us"); + e_goto (1, cmdline-1); /* draw line across bottom of screen */ + e_putline (string); + + e_ctrl ("ue"); + e_ctrl ("so"); + e_goto (maxcol - 18, cmdline); + + for (i=FIRST_CMD; (i<=numcommands) && (command[i].cmd != GET_HELP); i++) + ; + e_putline (command[i].keystroke); /* show the help command */ + e_ctrl ("se"); + e_putline (" for HELP"); + + fflush (stdout); +} + + +/* E_DRAWKEY -- Format and display the keyline. It is assumed that for + * arrays, the prompt occurs above the first array line. This enables the + * user to label his columns. We must handle multiline prompts as well. + * For maximum drawing speed output is optimized using line clears and screen + * gotos rather than blanks to erase and position text. + */ +void +e_drawkey (void) +{ + char valuebuf[MAXPROMPT]; + char tempbuf[MAXPROMPT]; + int offset, nchars; + + + e_encode_vstring (parmlist[keyid], valuebuf); + e_goto (1, line); + e_clrline(); + + if (parmlist[keyid]->p_type & PT_ARRAY) { + e_putline ("\t= "); + e_putline (valuebuf); + } else { + int hidden; + + hidden = (parmlist[keyid]->p_mode & M_HIDDEN); + + /* Print parameter name. Enclose hidden parameters in (), as in + * lparam. We lose a character in the name, but at least we know + * when a parameter is hidden. + */ + if (hidden) + sprintf (tempbuf, "(%-7.7s=", parmlist[keyid]->p_name); + else + sprintf (tempbuf, "%-8.8s=", parmlist[keyid]->p_name); + e_putline (tempbuf); + + /* Print the value string right justified in the value field. + */ + nchars = strlen (valuebuf); + offset = PROMPTOFFSET - nchars - 1; + offset = (VALUEOFFSET > offset) ? VALUEOFFSET : offset; + e_goto (offset, line); + + if (hidden) /* closing ) for hidden parameters */ + strcat (valuebuf, ")"); + e_putline (valuebuf); + + /* Print the (possibly multiline) prompt string. Do not write over + * the value string if it's a long one. + */ + offset += (nchars + 1); /* offset of prompt string */ + if (offset < PROMPTOFFSET) + offset = PROMPTOFFSET; + + /* Add one to the offset (for ')' in hidden parameters) and display + * the prompt. Continuation lines start at the standard prompt + * offset. + */ + e_displayml (parmlist[keyid]->p_prompt, line, ++offset, + PROMPTOFFSET + 1); + } +} + + +/* E_INDENT_PROMPT -- Must handle multiline prompts, i.e. prompt string may + * have imbedded newlines. Convert newline into newline plus the number of + * spaces to indent. +e_indent_prompt (p, bp, indent) +char *p; +char *bp; +int indent; +{ + register int i; + register char c; + + while ((*bp++ = c = *p++) != '\0') + if (c == '\n') + for (i=0; i < indent; i++) + *bp++ = ' '; +} + */ + + +/* E_ENCODE_VSTRING -- Get the value as a string for editing. If it's an array, + * get several of the values. If it is an array, make sure the undefined values + * get a '***', without calling spparval (which would bomb). + */ +void +e_encode_vstring ( + struct param *pp, + char *outbuf +) +{ + char valuebuf[G_MAXSTRING]; + char colbuf[16]; + + *outbuf = '\0'; + + if (pp->p_type & PT_ARRAY) { + int first, i, nn, numonrow; + struct operand o; + short len; /* the length of the first dim */ + + len = pp->p_val.v_a->a_len; + first = firstelement[keyid]; + + nn = len - ((first-1) % len); + numonrow = (nn > MAX_ON_ROW) ? MAX_ON_ROW : nn; + + for (i=first; i < first+numonrow; i++) { + /* First determine if the value is undefined or not. + */ + poffset (i-1); + paramget (pp, FN_VALUE); + o = popop(); + + if (opundef (&o)) + sprintf (colbuf," ***"); + else { + if ((pp->p_type & OT_BASIC) == OT_REAL) { + /* For real numbers, do not use spparval since we may + * lose exponents in the formatting. Limit output but + * use the %g format directly. + */ + sprintf (colbuf, "%10g ", o.o_val.v_r); + if (index (colbuf, '.') == NULL) + strcat (colbuf, "."); + } else { + poffset (i-1); + spparval (valuebuf, pp); + sprintf (colbuf, "%10.10s ", valuebuf); + } + } + + strcat (outbuf, colbuf); + } + + } else { + /* Do not use a high level routine such as paramget() to fetch + * the parameter value, as we do not want to deal with parameter + * indirection here. Just print the immediate value of the + * parameter as a string. + */ + if (opundef (&pp->p_valo)) + *outbuf = EOS; + else + sprop (outbuf, &pp->p_valo); + } +} + + +/* E_CHECK_VALS -- Perform range checking and reset the default if the string + * contains a partial array (yea, even a whole array). Parse each element of + * the array and check it. Also check whether there are enough elements in the + * array. In any case, if gquery returns an error, report that to the user. + */ +void +e_check_vals ( + char *string +) +{ + char *gquery(); /* declare gquery as returning a pointer */ + char *errstr; /* pointer to the error string (or 0) */ + char message[SZ_LINE+1];/* error message string */ + int badnews; /* a flag if an array element is in error */ + int isarray; /* a flag to indicate if this is an array */ + int numonrow; /* the number of elements on a row */ + + isarray = parmlist[keyid]->p_type & PT_ARRAY; + badnews = 0; + + if (cldebug) { + sprintf (dbg, "string = |%s| ", string); + E_DEBUG (dbg); + } + + if (isarray) { + char outstring[G_MAXSTRING]; + char *in, *e_getfield(); + int first, nelem, flen; + + /* Get the length of the first dimension, and the starting point. + */ + flen = parmlist[keyid]->p_val.v_a->a_len; + first = firstelement[keyid]; + + /* Determine how many elements SHOULD be on the row. + */ + nelem = flen - (first-1) % flen; + numonrow = (nelem > MAX_ON_ROW) ? MAX_ON_ROW : nelem; + + in = string; + badnews = 0; + nelem = 0; + + /* Parse each element of the string. + */ + while (!badnews) { + in = e_getfield (in, outstring, G_MAXSTRING); + if (outstring[0] == '\0') + break; + else + nelem++; + + if (e_undef (outstring)) + errstr = "OK"; + else { + poffset (first+nelem-2); /* push absolute index */ + errstr = gquery (parmlist[keyid], outstring); + } + + if (strcmp (errstr, "OK") != 0) { + sprintf (message, "%s [%s]?", errstr, outstring); + badnews++; + } + } + + if ((nelem != numonrow) && !(badnews)) { + sprintf (message, "Expected %d elements on this line",numonrow); + badnews++; + } + + } else { + /* Not an array. + */ + errstr = gquery (parmlist[keyid], string); + if (strcmp (errstr, "OK") != 0) { + strcpy (message, errstr); + badnews++; + } + } + + /* Report any errors. */ + if (badnews) + e_rpterror (message); + + /* Reprint the line. */ + e_drawkey(); + e_goto (startcol, line); + fflush (stdout); +} + + +/* E_UNDEF -- Recognize the undefined string of 3 asterisks. + */ +int +e_undef ( + register char *s +) +{ + register int n = 0; + + for (; (*s != '*') && (*s != '\0'); s++) + ; + for (; (*s == '*') && (*s != '\0'); s++) + n++; + + return (n == 3); +} + + +static char message[SZ_LINE]; /* used by e_rpterror and e_clrerror */ + +/* E_RPTERROR -- Report the error for the eparam user. + */ +void +e_rpterror ( + char *errstr +) +{ + char *range; /* pointer to the range error string */ + + if (parmlist[keyid]->p_type == OT_BOOL) { + sprintf (message, "%s must be `yes' or `no'", errstr); + } else if ((parmlist[keyid]->p_type == OT_STRING) + && !(parmlist[keyid]->p_flags & P_UMIN)) { + range = enumin (parmlist[keyid]); + sprintf (message, "What? %s", range); + } else { + range = minmax (parmlist[keyid]); + sprintf (message, "%s %s", errstr, range); + } + + /* Display at most one line of error message to avoid having to redraw + * the screen. + */ + message[maxcol-1] = '\0'; + e_display (message, cmdline, 1); + e_putline ("\007"); + error_displayed = 1; + + /* Edit the same keyline over again. + */ + nextline = line; + nextkey = keyid; + fflush (stdout); +} + + +/* E_CLRERROR -- Clear the error line, i.e. the last error message. + */ +void +e_clrerror (void) +{ + register int i, len; + + len = strlen (message); + + for (i=0; i < len; i++) + message[i] = ' '; + message[len] = '\0'; + + e_display (message, cmdline, 1); + error_displayed = 0; + + /* Edit the same keyline over again. + */ + nextline = line; + nextkey = keyid; + e_goto (startcol, line); + fflush (stdout); +} + + +/* E_GETFIELD -- Extract the next newline or comma delimited token from + * a string. Returns as the function value a pointer to the first char + * after the token. + */ +char * +e_getfield ( + register char *ip, /* pointer into input string */ + char *outstr, /* receives token */ + int maxch /* max chars out */ +) +{ + register char *op, *otop; + + while (*ip == ' ' || *ip == ',') + ip++; + otop = &outstr[maxch]; + for (op=outstr; *ip != '\0' && *ip != ' ' && *ip != ','; ) { + *op++ = *ip++; + if (op >= otop) + break; + } + *op = '\0'; + + return (ip); +} + + +/* E_MOREFLAG -- Signal that there are more parameters above or below the + * window. + */ +int +e_moreflag ( + register int topkey +) +{ + if ((numkeys == botkey) && (topkey == 1)) + return (OK); + + if (botkey < numkeys) { + e_ctrl ("so"); + e_ctrl ("us"); + e_display ("More", botline+1, 1); + } else { + e_ctrl ("us"); + e_display (" ", botline+1, 1); + } + + if (topkey != 1) { + e_ctrl ("so"); + e_display ("More", topline-1, 1); + } else { + e_ctrl ("se"); + e_ctrl ("ue"); + e_display (" ", topline-1, 1); + } + + e_ctrl ("se"); + e_ctrl ("ue"); + fflush (stdout); + + return (OK); +} + + +/* E_SCROLLIT -- Scroll the window if possible. + */ +int +e_scrollit (void) +{ + register int i; + + if (nextline == cmdline) { + ; + + } else if (nextline > botline) { + topkey = nextkey; + nextline = topline; + if (parmlist[topkey]->p_type & PT_ARRAY) + nextline += keylines[topkey] - 1; + e_repaint(); + + } else if (nextline < topline) { + for (i=0; topkeys[i] <= nextkey && topkeys[i] > 0; i++) + ; + topkey = topkeys[i-1]; + e_repaint(); + nextline = botkeyline; /* set in e_repaint */ + + } else if (nextline != topline) { + for (i=0; i <= maxpage; i++) { + if (topkeys[i] == nextkey && nextkey != topkey) { + topkey = nextkey; + nextline = topline; + if (parmlist[topkey]->p_type & PT_ARRAY) + nextline += keylines[topkey] - 1; + e_repaint(); + } + } + } + + return (OK); +} + + +/* EDIT_HISTORY_DIRECTIVE -- Main entry point of EHIST, an interactive history + * editor. + * + * EHIST is similar to the IRAF history commands to fetch a previous command, + * except that it allows the user to edit it interactively. The command is + * highlighted (optionally) and the user's line editor is invoked. + * + * This command is invoked by: + * + * ehist (== ^) edit the previous command + * ehist 3 (== ^3) edit command number 3 + * ehist a* (== ^a*) edit the previous command beginning with 'a' + * + * A 'return' or EXIT_UPDATE will execute the edited command. + * An EXIT_NOUPDATE will not execute the edited command. + */ +int +edit_history_directive ( + char *args, /* ehistory argument list */ + char *new_cmd /* the command to be executed after editing */ +) +{ + static char *firstchr[MAX_COMMANDS]; /*array of character pointers */ + static char string[G_MAXSTRING]; + char arglist[SZ_LINE+1]; + int execute, nchars, ochars, i; + int ice; /* flag for interactive command editor */ + int record; /* record number of the history record */ + int numchar; /* number of characters in the new command */ + char *lc, *sc; + + /* Convert the ehist command into the form "^histcmd", fetch the + * command from the history, and start EHIST up. + */ + arglist[0] = '^'; + strcpy (&arglist[1], args); + execute = process_history_directive (arglist, new_cmd); + + standout = eh_standout; /* set standout value */ + e_ttyinit(); /* initialize the terminal */ + edtinit(); /* and initialize the editor */ + ice = YES; + + while (ice) { + /* Count the number of keylines and setup the first character + * pointers. + */ + firstchr[1] = new_cmd; + for (numkeys=1, sc=new_cmd; *sc != '\0'; sc++) + if (*sc == '\n') { + numkeys++; + firstchr[numkeys] = sc + 1; + keylines[numkeys] = 1; + } + + numkeys--; + firstchr[numkeys+1] = sc; + + topline = cmdline - numkeys; + botline = cmdline - 1; + startcol = 1; + + numchar = strlen(new_cmd) - 1; + line = topline; + if (eh_bol) + nextcol = startcol; + else + nextcol = startcol + numchar; + + e_ctrl ("so"); + e_display (new_cmd, cmdline, 1); + e_ctrl ("se"); + fflush (stdout); + + *(new_cmd+numchar) = '\0'; /* get rid of the newline at the end. */ + nextkey = 1; + + /* Main EHIST loop. + */ + while (nextkey > 0) { + /* Copy the next command. + */ + sc = string, lc = firstchr[nextkey]; + while ((*lc != '\n') && (*lc != '\0')) { + /* KLUDGE fix for tabs for the moment. */ + if ((*sc = *lc) == '\t') + *sc = ' '; + lc++, sc++; + } + *sc = '\0'; + + keyid = nextkey; + /* line = topline + keyid - 1; 24Feb87 */ + line = topline + keyid; + col = nextcol; + + e_goto (col, line); + fflush (stdout); + ochars = strlen (string); + nchars = editstring (string, NO); + + /* Shift commands to the right of this one. + */ + if (nchars > ochars) { + lc = firstchr[numkeys+1] + nchars - ochars; + while (lc >= firstchr[keyid+1] - 1) { + *lc = *(lc - nchars + ochars); + --lc; + } + } + + /* Insert the revised string inplace. + */ + for (sc=string, lc=firstchr[keyid]; *sc != '\0'; sc++, lc++) + *lc = *sc; + *lc = '\n'; + + /* Move the following commands if necessary. + */ + if (nchars < ochars) + for (lc=firstchr[keyid+1]; *lc !='\0'; lc++) + *(lc+nchars-ochars) = *lc; + + /* Revise the firstchr pointers. + */ + for (i = keyid+1; i <= numkeys; i++) + firstchr[i] = firstchr[i] + nchars-ochars; + + numchar += nchars - ochars; + keyid += nextline - line; + + } /* end of while (nextkey) */ + + *(new_cmd+numchar) = '\n'; + *(new_cmd+numchar+1) = '\0'; + + execute = (nextkey < 0) ? 0 : 1; + + if (nextline < topline) { + record = what_record() + 1; + if (get_history (record, new_cmd, SZ_CMDBLK) == ERR) + ice = NO; + } else if (nextline > botline) { + record = what_record() - 1; + if (get_history (record, new_cmd, SZ_CMDBLK) == ERR) + ice = NO; + } else + ice = NO; + + } /* end of ice loop */ + + edtexit(); + e_ttyexit(); + printf ("\n"); + fflush (stdout); + + return (execute); +} + + +/* EDITSTRING -- A very limited string editor for interactive input. The number + * of characters in the edited string is returned as the function value. + */ +int +editstring ( + char *string, + int eparam /* flag to indicate eparam or ehis */ +) +{ + char oldchar; /* save old character after delete */ + char oldword[G_MAXSTRING]; /* save the deleted word */ + char oldline[G_MAXSTRING]; /* save the deleted line */ + char tempstr[G_MAXSTRING]; + char *chn; + char *cp; /* pointer to char within string */ + char *lc; /* pointer to last char */ + int oldnum = 0; /* for DEL_WORD and UNDEL_WORD */ + int numchar; /* number of characters in string */ + int cmd; /* the command identifier */ + int direction; /* the cursor direction */ + int gotstring, i, numdel, ch; + + gotstring = NO; /* dont have anything yet */ + + if (eparam) { + /* Start out with an empty string, saving the old value of + * the parameter in "oldline". + */ + strcpy (oldline, string); + numchar = 0; + cp = string; + *cp = '\0'; + } else { + /* Edit history. Start at either EOL or BOL depending upon + * value of switch set by user. + */ + numchar = strlen (string); + if (eh_bol) + cp = string; + else + cp = string + numchar; + } + + direction = FWD; + col = startcol + (cp - string); + + while (!gotstring) { + + /* Fetch the next keystroke. + */ + ch = fgetc (stdin); + if (error_displayed) + e_clrerror(); + + /* Map to lower case if ucasein switch is set. The ^ shift escape + * sequence is not currently supported. + */ + if (e_ucasein && isupper(ch)) + ch = tolower (ch); + + if (ch == EOF) { + /* EOF returned; should not happen, so return. + */ + gotstring = YES; + nextline = cmdline; + continue; + + } else if (eparam && ch == ':' && col == startcol) { + /* Colon escape. + */ + if (e_colon() == EP_EOF) { + gotstring = YES; + nextline = cmdline; + } else { + e_goto (col, line); + fflush (stdout); + } + continue; + + } else if (ch == ' ' || ch == '\t' || isprint(ch)) { + /* Normal character. + */ + + /* KLUDGE fix for tabs for the moment. */ + ch = (ch == '\t') ? ' ' : ch; + + /* Copy what's to the right. */ + for (lc = string + numchar +1; lc > cp; --lc) + *lc = *(lc-1); + *cp = ch; /* substitute the new char */ + + if (cp >= (string + G_MAXSTRING)) + continue; + lc = cp; numchar++; col++; cp++; + e_ctrl ("so"); + e_putline (lc); + e_ctrl ("se"); + e_goto (col, line); + fflush (stdout); + continue; + + } else if (ch == '\r') { + /* Carriage return. + */ + if (eparam) + gotstring = e_movedown (eparam); + else { + nextkey = 0; + nextline = botline; + gotstring = YES; + } + continue; + + } else { + /* Find out if it is a legitimate edit command. + */ + cmd = what_cmd (ch); + } + + /* Perform the editing function. + */ + switch (cmd) { + + case MOVE_UP: + gotstring = e_moveup (eparam); + break; + + case MOVE_DOWN: + gotstring = e_movedown (eparam); + break; + + case MOVE_RIGHT: + if (cp < (string+numchar)) /* dont move beyond string */ + if (col < maxcol) /* dont move beyond screen */ + cp++; + break; + + case MOVE_LEFT: + if (cp > string) /* dont move too far */ + --cp; + break; + + case NEXT_WORD: + if (direction != AFT) { + if (cp != (string+numchar)) + cp = e_tonextword (cp); + else + gotstring = e_movedown (eparam); + break; + } + /* fall through to the PREV_WORD case (no break) */ + + case PREV_WORD: + if (cp != string) + cp = e_toprevword (cp, string); + else + gotstring = e_moveup (eparam); + break; + + case MOVE_EOL: + /* Move to the end of the current line. + */ + if (cp < (string+numchar)) { + cp = string + numchar; + break; + } + + if (direction == AFT) + gotstring = e_moveup (eparam); + else + gotstring = e_movedown (eparam); + break; + + case MOVE_BOL: + /* Move to the beginning of the current line. + */ + cp = string; + break; + + case NEXT_LINE: + if (direction == AFT) + gotstring = e_moveup (eparam); + else + gotstring = e_movedown (eparam); + break; + + case NEXT_PAGE: + if (eparam) { + if (botkey != numkeys) { + nextline = botline + 1; + nextkey = botkey + 1; + } else { + nextline = botkeyline; + nextkey = botkey; + } + gotstring = YES; + } + break; + + case PREV_PAGE: + if (eparam) { + if (topkey != 1) { + nextline = topline - 1; + nextkey = topkey - 1; + } else { + nextline = topline; + nextkey = topkey; + } + gotstring = YES; + } + break; + + case MOVE_START: + if (eparam) { + if (topkey == 1) { + nextline = topline; + nextkey = topkey; + } else { + nextline = botline + 1; + nextkey = 1; + } + gotstring = YES; + } + break; + + case MOVE_END: + if (eparam) { + if (botkey == numkeys) { + nextline = botkeyline; + nextkey = botkey; + } else { + nextline = topline - 1; + nextkey = numkeys; + } + gotstring = YES; + } + break; + + case SET_FWD: + direction = FWD; + break; + + case SET_AFT: + direction = AFT; + break; + + case TOGGLE_DIR: + if (direction == AFT) + direction = FWD; + else + direction = AFT; + break; + + case DEL_LEFT: + chn = cp - 1; + if (numchar > 0) { + oldchar = *chn; + strcpy (chn, chn+1); + if (cp > string) + --cp; + --numchar; + + e_display (string, line, startcol); + + e_goto (startcol + numchar, line); + e_putline (" "); + fflush (stdout); + } + break; + + case DEL_CHAR: + /* Delete the character under the cursor. + */ + chn = cp; + if ((numchar > 0) && (cp < (string+numchar))) { + oldchar = *chn; + strcpy (chn, chn+1); + --numchar; + + e_display (string, line, startcol); + + e_goto (startcol + numchar, line); + e_putline (" "); + fflush (stdout); + } + break; + + case UNDEL_CHAR: + /* Undelete the last character deleted. + */ + for (lc=string+numchar+1; lc >= cp; --lc) + *lc = *(lc-1); + *cp = oldchar; + numchar++; + e_display (string, line, startcol); + break; + + case DEL_WORD: + if (cp >= (string + numchar)) /* end of line */ + break; + + chn = e_tonextword (cp); + + if ((numchar > 0) && (chn != cp)) { + numdel = chn - cp; + strncpy (oldword, cp, numdel); + oldnum = numdel; + strcpy (cp, chn); + numchar -= numdel; + + e_display (string, line, startcol); + + e_goto (startcol + numchar, line); + for (i=0; i < numdel; i++) + e_putline (" "); + fflush (stdout); + } + break; + + case UNDEL_WORD: + if (oldnum > 0) { + strcpy (tempstr, cp); /* save the end */ + strncpy (cp, oldword, oldnum); + strcpy (cp+oldnum, tempstr); + numchar = numchar + oldnum; + e_display (string, line, startcol); + } + break; + + case DEL_LINE: + strcpy (oldline, cp); + *cp= '\0'; + chn = string + numchar; + numdel = chn - cp; + numchar = cp - string; + + e_display (string, line, startcol); + + e_goto (startcol + numchar, line); + for (i=0; i < numdel; i++) + e_putline (" "); + fflush (stdout); + break; + + case UNDEL_LINE: + /* Erase current value totally; don't want extraneous + * characters floating around. + */ + e_goto (startcol, line); + numchar = PROMPTOFFSET - startcol; + for (i=0; i < numchar; i++) + e_putline (" "); + + /* Now, get the old line and display it. + */ + strcpy (cp, oldline); + numchar = strlen (string); + cp = string + numchar; + e_display (string, line, startcol); + break; + + case GET_HELP: + show_editorhelp(); + + /* fall through */ + + case REPAINT: + if (eparam) { + nextkey = keyid; + e_repaint(); + keyid = nextkey; + } + e_ctrl ("so"); + e_display (string, line, startcol); + e_ctrl ("se"); + break; + + case EXIT_NOUPDATE: + if (eparam) { + nextline = cmdline; + ep_status = ERR; + } else { + nextkey = -1; + nextline= botline; + } + gotstring = YES; + break; + + case EXIT_UPDATE: + if (eparam) { + nextline = cmdline; + if (numchar > 0) + e_check_vals (string); + } else + nextline = botline; + + nextkey = 0; + gotstring = YES; + break; + + default: + e_putline ("\007"); + break; + } + + col = startcol + cp - string; + e_goto (col, line); + fflush (stdout); + } + + return (numchar); +} + + +/* E_TTYINIT -- Initialize the terminal, i.e., set raw mode and standout mode + * (if enabled). Get dimensions of terminal screen. + */ +void +e_ttyinit (void) +{ + /* Open the tty (termcap) descriptor for the terminal. + */ + if ((tty = c_ttyodes ("terminal")) == ERR) + c_erract (EA_ERROR); + + /* Set raw mode on the standard input. + */ + c_fseti (fileno(stdin), F_RAW, YES); + + /* The following is to support monocase (upper case only) terminals, + * or normal dualcase terminals in shift lock mode. Normally the + * terminal driver handles this, but since this is a raw mode + * interface case mapping is disabled. Determine if ucasein and + * ucaseout have been selected, e.g., with `stty ucasein ucaseout'. + */ + e_ucasein = c_ttstati ((XINT)STDIN, TT_UCASEIN); + e_ucaseout = c_ttstati ((XINT)STDOUT, TT_UCASEOUT); + + /* Get the dimensions of the terminal screen from the environment. + * These need not agree with the physical screen dimensions given + * in the termcap descriptor. + */ + c_xttysize (&maxcol, &cmdline); + startcol = G_STARTCOL; + topline = G_TOPLINE; + botline = cmdline - (G_CMDLINE - G_BOTLINE); + + tty_fd = fileno(stdout); +} + + +/* E_COLON -- Process a colon escape. Prompt with a : on the status line, + * get the command from the user, and either execute the command or return + * the command to the procedure which called eparam. As far as possible, + * all error checking should be performed before exiting, so that eparam + * does not exit when an invalid colon escape is entered. EP_EOF is returned + * as the function value if eparam is to exit. + */ +int +e_colon (void) +{ + register char *ip, *op; + register int ch; + char buf[SZ_LINE+1], *pset; + struct param *pp; + int ucasein_set; + int force, n; + + ucasein_set = c_ttstati ((XINT)STDIN, TT_UCASEIN); + + /* Go to the command line, clear it and read the string value. + * The read is performed in raw mode to avoid a line feed and scroll + * when the CR is typed. + */ +again_: + c_ttygoto (tty_fd, tty, 1, cmdline); + c_ttyclearln (tty_fd, tty); + c_ttyctrl (tty_fd, tty, "se", 1); + c_ttyputline (tty_fd, tty, "\r:", NO); + c_flush (tty_fd); + + for (op=buf; (ch = fgetc (stdin)) != EOF; ) { + if (ch == '\177' || ch == '\010') { /* delete */ + if (op > buf) { + *--op = EOS; + c_ttyclearln (tty_fd, tty); + c_ttyputline (tty_fd, tty, "\r:", NO); + c_ttyputline (tty_fd, tty, buf, NO); + c_flush (tty_fd); + } else { + /* A delete at bol gets us out of colon mode. */ + break; + } + } else if (ch == '\003' || ch == '\025') { /* ^C, ^U */ + c_ttyclearln (tty_fd, tty); + goto again_; + } else if (ch == '\n' || ch == '\r' || (op - buf) >= SZ_LINE) { + break; + } else { + fputc (ch, stdout); + c_flush (tty_fd); + if (ucasein_set && isupper (ch)) + *op++ = tolower (ch); + else + *op++ = ch; + } + } + *op = EOS; + + /* Parse the colon directive. + */ + for (ip=buf; isspace (*ip); ip++) + ; + if (*ip == EOS) { + c_ttyclearln (tty_fd, tty); + return (OK); /* null command */ + } + + ch = *ip++; + if (ch == 'g' && *ip == 'o') + ip++; + if ((force = (*ip == '!'))) + ip++; + for (; isspace (*ip); ip++) + ; + pset = ip; + + /* Process the colon directive. + */ + switch (ch) { + case 'q': + /* Exit. The pfile is automatically updated unless :q! is used. + */ + if (force) + ep_update = NO; + return (EP_EOF); + + case 'w': + /* Update the pfile currently being edited if no arg, else + * write the named pfile. + */ + if (*pset == EOS) + n = pfilewrite (pfilep, pfilep->pf_pfilename); + else if (strcmp (pset, "q") == 0) /* ":wq" */ + return (EP_EOF); + else { + if (force || c_access (pset, 0,0) == NO) + n = pfilewrite (pfilep, pset); + else { + sprintf (buf, + "File exists - use `w! %s' to overwrite", pset); + e_puterr (buf); + return (ERR); + } + } + + sprintf (buf, " - %d parameters written to %s", n, + (*pset == EOS) ? pfilep->pf_pfilename : pset); + e_putline (buf); + fflush (stdout); + return (OK); + + case 'r': + /* Load a new set of parameter values into the parameter set + * currently being edited. If no argument is given the main + * task pset is reloaded. + */ + if (*pset == EOS) { + if (force) { + strcpy (e_nextpset, e_cx->e_pset); + ep_nextcmd = EP_EDIT; + ep_update = NO; + return (EP_EOF); + } else { + e_puterr ("Use `r!' to reload current pset"); + return (ERR); + } + } else { + if (e_psetok (pset)) { + pfilemerge (e_cx->e_cpfp, pset); + + /* If we're forcing the new parameters, update + * the pfile on disk so we can execute it immediately. + */ + if (force) + n = pfilewrite (pfilep, pfilep->pf_pfilename); + + e_repaint(); + return (OK); + } else + return (ERR); + } + + case 'e': + /* Edit the pset whose name is given by the string value of the + * current parameter. + */ + if (*pset != EOS) { + /* Edit a new pset, discarding current context. + */ + if (e_psetok (pset)) { + strcpy (e_nextpset, pset); + ep_nextcmd = EP_EDIT; + return (EP_EOF); + } else + return (ERR); + + } else { + /* Edit the pset pointed to by the pset parameter currently + * under the cursor (only works for pset parameters). + */ + pp = parmlist[keyid]; + if (!(pp->p_type & PT_PSET)) { + sprintf (buf, "parameter `%s' is not a pset parameter", + pp->p_name); + e_puterr (buf); + return (ERR); + } + + /* Get the pset name. This is the string value of the pset + * parameter, else the name of the parameter itself. + */ + e_encode_vstring (pp, buf); + if (*buf == EOS) + pset = pp->p_name; + else + pset = buf; + + if (e_psetok (pset)) { + strcpy (e_nextpset, pset); + ep_nextcmd = EP_DESCEND; + return (EP_EOF); + } else + return (ERR); + } + + case 'g': + /* Exit and run the task. + */ + if (force) + ep_update = NO; + if (*pset == EOS) + pset = e_cx->e_pset; + + if (is_pfilename (pset)) { + e_puterr ("cannot execute a pfile"); + return (ERR); + } else { + strcpy (e_nextpset, pset); + ep_nextcmd = EP_RUN; + return (EP_EOF); + } + + default: + e_puterr ("Invalid colon escape directive"); + return (ERR); + } +} + + +/* E_PSETOK -- Verify that the named pfile exists and can be read. Report + * any problems to the user. + */ +int +e_psetok ( + char *pset +) +{ + register struct pfile *pfp; + char errmsg[SZ_LINE+1], *errfmt, *errarg; + XINT save_topd; + + save_topd = topd; + errarg = pset; + pfp = NULL; + + if (is_pfilename (pset)) { + /* Verify valid file pset. + */ + if (c_access (pset, 0,0) == NO) { + errfmt = "pfile `%s' does not exist"; + goto error_; + } else if ((pfp = pfileread (NULL, pset, 0)) == NULL) { + errfmt = e_badpfile; + goto error_; + } + + } else { + /* Verify valid ltask pset. + */ + char *x1, *pk, *lt, *x2; + struct package *pkp; + struct ltask *ltp; + + breakout (pset, &x1, &pk, <, &x2); + ltp = _ltasksrch (pk, lt, &pkp); + + if (pkp == NULL) { + errfmt = e_pcknonexist; + errarg = pk; + goto error_; + } else if ((XINT)pkp == ERR) { + errfmt = e_pckambig; + errarg = pk; + goto error_; + } else if (ltp == NULL) { + errfmt = e_tnonexist; + errarg = lt; + goto error_; + } else if ((XINT)ltp == ERR) { + errfmt = e_tambig; + errarg = lt; + goto error_; + } + + if (!(ltp->lt_flags & LT_PFILE)) { + errfmt = e_nopfile; + goto error_; + } else if ((pfp = pfileload (ltp)) == NULL) { + errfmt = e_badpfile; + goto error_; + } + } + + /* If we get here we presumably have a valid pset. Return memory + * and return YES to the caller, indicating that the pset is valid. + */ + if (pfp) + pfileunlink (pfp); + topd = save_topd; + return (YES); + +error_: + sprintf (errmsg, errfmt, errarg); + e_puterr (errmsg); + return (NO); +} + + +/* E_PUTERR -- Put an error message on the command line. + */ +void +e_puterr ( + char *errmsg +) +{ + c_ttygoto (tty_fd, tty, 1, cmdline); + c_ttyclearln (tty_fd, tty); + e_putline (errmsg); +} + + +/* E_TTYEXIT -- Turn off raw mode and standout mode and close the termcap + * descriptor, leaving everything as we found it. + */ +void +e_ttyexit (void) +{ + c_fseti (fileno(stdin), F_RAW, NO); /* unset raw mode */ + + c_ttygoto (tty_fd, tty, 1, cmdline); + c_ttyctrl (tty_fd, tty, "se", 1); + c_ttycdes (tty); + + fflush (stdout); +} + + +/* E_MOVEUP -- Move the cursor up one line. + */ +int +e_moveup ( + int eparam +) +{ + if (keyid != 1) { + /* Can go up further. + */ + nextkey = keyid - 1; + if (line == topline) /* over the top */ + nextline = topline - 1; + else { + nextline = line - keylines[nextkey]; + if (eparam) { + if ((parmlist[nextkey]->p_type & PT_ARRAY)) + if (firstelement[nextkey] == 1) + nextline = line - 1; + + if ((parmlist[keyid]->p_type & PT_ARRAY)) + if (firstelement[keyid] == 1) + nextline = nextline - keylines[keyid] + 1; + } + if (nextline < topline) + nextline = topline - 1; + } + + } else if (!eparam) { + nextline = topline - 1; + nextkey = -1; + } + + return (YES); +} + + +/* E_MOVEDOWN -- Move the cursor down one line. + */ +int +e_movedown ( + int eparam +) +{ + if (keyid != numkeys) { + /* get downnnnn!! + */ + nextkey = keyid+1; + if (line == botline) + nextline = botline+1; + else { + nextline = line + keylines[keyid]; + if (eparam) { + if ((parmlist[keyid]->p_type & PT_ARRAY)) + if (firstelement[keyid] == 1) + nextline = line + 1; + + /* Make room for prompt */ + if ((parmlist[nextkey]->p_type & PT_ARRAY)) + if (firstelement[nextkey] == 1) + nextline = nextline + keylines[nextkey] - 1; + } + if (nextline > botline) + nextline = botline + 1; + } + + } else if (!eparam) { + nextline = botline+1; + nextkey = -1; + } + + if (cldebug) { + sprintf (dbg, "nextline=%d, nextkey=%d line=%d keys=%d", + nextline, nextkey, line, keylines[nextkey]); + E_DEBUG(dbg); + } + + return (YES); +} + + +/* E_TONEXTWORD -- Skip forward to the beginning of the next word. + */ +char * +e_tonextword ( + register char *ip +) +{ + ip++; + + /* Pass over leading characters. */ + while (*ip && !isspace (*ip)) + ip++; + + /* Find the next character. */ + while (*ip && isspace(*ip)) + ip++; + + return (ip); +} + + +/* E_TOPREVWORD -- Find the beginning of the previous word. + */ +char * +e_toprevword ( + char *ip, + char *string +) +{ + --ip; + + /* Pass over leading blanks. */ + if (*ip == ' ') + for (; (*ip == ' ') && (ip != string); --ip) + ; + + /* Find the preceding blank. */ + for (; (*ip != ' ') && (ip != string); --ip) + ; + if ((*ip != ' ') && (ip == string)) + ; + else + ip++; + + return (ip); +} + + +/* E_CTRL -- Send a control sequence to the terminal. + */ +void +e_ctrl ( + char *cap +) +{ + /* Check for start standout or start underline mode. + */ + if (strcmp(cap,"so") == 0 || strcmp(cap,"us") == 0) + if (standout == NO) + return; + + c_ttyctrl (tty_fd, tty, cap, 1); +} + + +/* E_GOTO -- High level edcap version of ttygoto (cursor addressing). + */ +void +e_goto ( + int col, + int line +) +{ + c_ttygoto (tty_fd, tty, col, line); +} + + +/* E_PUTLINE -- Put a line of text to the terminal. Do not map any embedded + * control codes (bell will get lost). + */ +void +e_putline ( + char *stwing +) +{ + register char *ip, *op; + register int ch, n; + char obuf[512]; + int map_cc=0; + + /* Map output to upper case if `stty ucaseout' mode is set (we have + * to do this here because of the raw i/o). + */ + if (e_ucaseout) { + for (ip=stwing, op=obuf, n=512; --n >= 0 && (ch = *ip++) != EOS; ) + *op++ = islower(ch) ? toupper(ch) : ch; + *op = EOS; + ip = obuf; + } else + ip = stwing; + + /* The flush calls are required to avoid mixing text and control + * sequences when doing raw i/o to monocase terminals. + */ + if (e_ucaseout) + c_flush (tty_fd); + c_ttyputline (tty_fd, tty, ip, map_cc); + if (e_ucaseout) + c_flush (tty_fd); +} + + +/* E_CLEAR -- Clear the screen (disables standout mode as a side effect). + */ +void +e_clear (void) +{ + c_ttyctrl (tty_fd, tty, "se", 1); + c_ttyctrl (tty_fd, tty, "ue", 1); + c_ttyclear (tty_fd, tty); +} + + +/* E_CLRLINE -- Clear the current line. + */ +void +e_clrline (void) +{ + c_ttyclearln (tty_fd, tty); +} + + +/* E_DISPLAY -- Output a possibly multiline string at the given screen + * coordinates. Each line is written starting at the same column on the + * screen. + */ +void +e_display ( + char *string, /* string to be printed */ + int sline, + int scol /* starting line and column */ +) +{ + e_displayml (string, sline, scol, scol); +} + + +/* E_DISPLAYML -- Display a possibly multiline prompt, with the first line + * starting a different column than the continuation lines. If a continuation + * line begins with \r (CR) it will be displayed starting at column 1, rather + * than starting at column scol. + */ +void +e_displayml ( + char *string, /* string to be printed */ + int sline, /* starting line and column */ + int scol, + int ccol /* start col of continuation lines */ +) +{ + register char *ip, *op; + char lbuf[512], *line; + int ocol; + + /* Display a series of newline delimited lines. + */ + for (ip=string, op=lbuf; *ip != EOS; ) + for (op=lbuf; (*op = *ip) != EOS; op++, ip++) + if (*op == '\n') { + *op = EOS; + /* Truncate line at right margin. If first char is \r, + * starting column is column 1 rather than scol. + */ + ocol = scol; line = lbuf; + while (*line == '\r') { + ocol = 1; + line++; + } + line[maxcol-ocol+1] = EOS; + + /* Display the line. */ + e_goto (ocol, sline++); + e_ctrl ("ce"); + e_putline (line); + op = lbuf - 1; + scol = ccol; + } + + /* Display any remaining, nonnewline-delimited line segment. + */ + if (op > lbuf) { + *op = EOS; + ocol = scol; line = lbuf; + while (*line == '\r') { + ocol = 1; + line++; + } + line[maxcol-ocol+1] = EOS; + e_goto (ocol, sline++); + e_putline (line); + } +} diff --git a/pkg/cl/eparam.h b/pkg/cl/eparam.h new file mode 100644 index 00000000..72ef1ab2 --- /dev/null +++ b/pkg/cl/eparam.h @@ -0,0 +1,108 @@ +/* + * EPARAM.H -- Definition of the string editing capabilities. The mapping + * of the commands is defined by the *.ed files in DEV. + */ + +#define FIRST_CMD 3 /* first command escape sequence */ +#define NUM_COMMANDS 35 /* number of recognized commands */ +#define MAX_COMMANDS 50 /* max commands recognized by edcap */ +#define SZ_ESCAPE 10 /* terminal escape sequence */ +#define SZ_KEYSTROKE 12 /* keystroke command name */ + +#define G_TOPLINE 6 /* top of eparam scrolling region */ +#define G_BOTLINE 22 /* bottom of eparam scrolling region */ +#define G_STARTCOL 11 /* start of eparam edit area */ +#define G_CMDLINE 24 /* command line for messages & exit */ + +#define G_MAXPARAM 100 /* maximum number of parameters */ +#define G_MAXPAGES 12 /* maximum number of pages */ +#define G_MAXSTRING 80 /* maximum size of the edit string */ +#define G_BIGSIZE 2048 /* sum of sizes of value fields */ +#define MAXPROMPT 2048 /* maximum characters in multiline pr. */ +#define PROMPTOFFSET 32 /* where the prompt starts */ +#define VALUEOFFSET 11 /* where the value field starts */ +#define MAX_ON_ROW 6 /* the number of %10.10s fields */ + +#define FWD 1 +#define AFT 0 + +/* eparam() context structure. + */ +struct ep_context { + int e_init; /* set on first call */ + XINT e_topd; /* save top of dictionary */ + int e_topkey; /* saved context variables */ + int e_line; /* " */ + int e_col; /* " */ + int e_nextkey; /* " */ + int e_nextline; /* " */ + struct pfile *e_mpfp; /* master pfile descriptor */ + struct pfile *e_cpfp; /* pfilecopy descriptor */ + char e_pset[SZ_FNAME+1]; /* pset name (task or file) */ +}; + +/* eparam() colon commands and exit status codes. + */ +#define EP_EOF 1 /* update pfile and pop context */ +#define EP_EDIT 2 /* discard context and edit */ +#define EP_DESCEND 3 /* push context and edit pfile */ +#define EP_RUN 4 /* exit and run task */ + +/* Editor initialization and termination sequences (these have to be first + * in case a 'define key' capability is added). + */ +#define EDITOR_ID 0 /* editor's name */ +#define EDIT_INIT 1 /* editor initialization sequence */ +#define EDIT_TERM 2 /* editor termination sequence */ + +/* edit commands */ + +#define MOVE_UP 3 /* move the cursor up one line */ +#define MOVE_DOWN 4 /* move the cursor down one line */ +#define MOVE_RIGHT 5 /* move the cursor one char to the right */ +#define MOVE_LEFT 6 /* move the cursor one char to the left */ +#define NEXT_WORD 7 /* move the cursor one word to the right */ +#define PREV_WORD 8 /* move the cursor one word to the left */ +#define MOVE_EOL 9 /* move the cursor to the end of line */ +#define MOVE_BOL 10 /* move the cursor to the beginning */ +#define NEXT_PAGE 11 /* move to the next page */ +#define PREV_PAGE 12 /* move to the previous page */ +#define MOVE_START 13 /* move to the start of the text */ +#define MOVE_END 14 /* move to the end of the text */ + +/* these commands are for EDT type editors */ +#define SET_FWD 15 /* set the direction forwards */ +#define SET_AFT 16 /* set the direction aftwards */ +#define TOGGLE_DIR 17 /* change the direction */ + +#define DEL_LEFT 18 /* delete the character to the left */ +#define DEL_CHAR 19 /* delete the character under the cursor */ +#define DEL_WORD 20 /* delete up to and including next delimiter */ +#define DEL_LINE 21 /* delete up to the end of line */ +#define UNDEL_CHAR 22 /* undelete the character */ +#define UNDEL_WORD 23 /* undelete the word */ +#define UNDEL_LINE 24 /* undelete the line */ + +#define FIND_FWD 25 /* find forward */ +#define FIND_AFT 26 /* find aftward */ +#define FIND_NEXT 27 /* find next */ +#define GET_HELP 28 /* display help information */ +#define REPAINT 29 /* clear and repaint the screen */ +#define EXIT_UPDATE 30 /* exit the editor */ +#define EXIT_NOUPDATE 31 /* exit the editor with no update */ + +#define NEXT_LINE 32 /* move to the next line */ +#define NOMORE_COMMANDS 99 /* last command terminator */ + +struct edit_commands { + int cmd; + char escape[SZ_ESCAPE+1]; + char keystroke[SZ_KEYSTROKE+1]; +}; + +extern struct edit_commands command[MAX_COMMANDS]; +extern char *cmdnames[MAX_COMMANDS]; +extern int numcommands; + +char *enumin(), *minmax(); +char *host_editor(); diff --git a/pkg/cl/errs.c b/pkg/cl/errs.c new file mode 100644 index 00000000..a93cf8a2 --- /dev/null +++ b/pkg/cl/errs.c @@ -0,0 +1,255 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_fset +#define import_stdio +#define import_setjmp +#define import_knames +#define import_xnames +#define import_stdarg +#include + +#include "config.h" +#include "clmodes.h" +#include "operand.h" +#include "param.h" +#include "task.h" +#include "mem.h" +#include "errs.h" +#include "grammar.h" +#include "construct.h" +#include "proto.h" + + +/* + * ERRS -- When a runtime operation detects an error, it calls error with an + * error type, a diagnostic string and some additional arguments. the type + * determines the severity and prefix for the diagnostic. the diagnositic + * and its args are written as an error message with doprnt. + * After the error message has been printed to our t_stderr, tasks are killed + * until an interactive cl is found. the longjmp forces the last + * setjmp (errenv) in main() to return and start the parser again. + * thus, a call to error() never returns but forces a reset back to an + * interactive state. + * + * Some frequently used diagnostic strings are defined here to avoid + * repetition. The list may be expanded or ignored as desired when new + * errors are added. + */ +extern int errlev; /* for detecting error recursion */ +extern int bkgno; /* bkg task number, if batch job */ +extern int validerrenv; /* set in main once get past login() */ +extern int loggingout; /* set while reading from logout file */ +extern int gologout; /* set when getting ready to " " " */ +extern jmp_buf errenv; /* setjmp() is in main(). */ + +char *e_appopen = "can not open `%s' for appending"; +char *e_badstrop = "illegal operation on string '%0.20s'"; +char *e_badsw = "bad switch case, %d, in `%s'"; +/* char *e_edom = "function argument outside valid range: %g"; */ +/* char *e_erange = "%g caused arithmetic overflow"; */ +/* char *e_fpe = "floating point exception"; */ +char *e_geonearg = "`%s' requires at least one argument"; +char *e_indexunf= "no indices on stack for array reference"; +char *e_nominmax = "structs, strings, cursors and booleans do not have ranges"; +char *e_nopfile = "task `%s' has no param file"; +char *e_badpfile = "cannot read parameter file `%s'"; +char *e_nostrcnv = "may not convert string to other types"; +/* char *e_notbool = "parameter `%s' is not boolean"; */ +char *e_onearg = "`%s' expects one argument"; +char *e_pambig = "ambiguous parameter `%s' within `%s'"; +char *e_pckambig = "ambiguous package `%s'"; +char *e_pcknonexist= "package `%s' not found"; +char *e_posargs = "too many positional arguments for `%s'"; +char *e_pnonexist = "parameter `%s' not found"; +char *e_ropen = "cannot open `%s' for reading"; +char *e_simplep = "use simple parameter name only for `%s'"; +char *e_strplusreal= "attempt to add operand of type real to string `%s'"; +char *e_soverflow = "stack overflow (cs:%d,os:%d)"; +char *e_sunderflow = "stack underflow"; +char *e_tambig = "ambiguous task `%s'"; +char *e_twoargs = "`%s' expects two arguments"; +char *e_tnonexist = "task `%s' not found"; +/* char *e_unlink = "cannot remove file `%s'"; */ +char *e_uopcode = "undefined opcode %d"; +char *e_wopen = "cannot open `%s' for writing"; +char *e_lookparm = "error searching for parameter `%s'."; +char *e_invaldef= "conflicting attributes in definition of `%s'."; +char *e_fdivzero = "floating divide by zero"; +char *e_idivzero = "integer divide by zero"; + +/* This variable is used to avoid duplicate error logging by the builtin + * clerror() and the error function cl_error() below. When a script or + * executable tasks calls the CL language 'error' function, the builtin + * clerror() logs the error message. Otherwise, we'll log it here. + */ +int errlog = 0; + +extern int u_doprnt(); + + +/* CL_ERROR -- print error info according to errtype on our t_stderr, pop back + * to an interactive task and do a longjmp back to setjmp (errenv) in + * main(); thus, whomever calls error() should not expect it to return. + * + * If errtype is or'd with E_P, also call perror() for more info. + * If we are a background task, print the task ordinal to tell the user + * which task aborted. + */ +void +cl_error (int errtype, char *diagstr, ...) +{ + va_list args; + register struct task *tp; + static int nfatal = 0; + static int break_locks = 1; + + va_start (args, diagstr); + + /* Safety measure, in the event of error recursion. + */ + if (nfatal) + clexit(); + + if (errlev++ > 2) { + nfatal++; + eprintf ("Error recursion. Cl dies.\n"); + clexit(); + } + + /* The first setjmp(errenv) is not done until we start the main loop. + * Set validerrenv when start the first interactive cl to indicate that + * we may safely longjmp back to main's loop on an error. ERRENV is + * not set for bkg jobs since error restart is not permitted. + */ + if (!validerrenv && !(firstask->t_flags & T_BATCH)) { + nfatal++; + u_doprnt (diagstr, &args, currentask->t_stderr); + if (errtype & E_P) + perror ("\nOS errmsg"); + else + eprintf ("\n"); + eprintf ("Fatal startup error. CL dies.\n"); + clexit(); + } + + /* Any error occurring during logout is fatal. + */ + if (loggingout || gologout) { + nfatal++; + u_doprnt (diagstr, &args, currentask->t_stderr); + if (errtype & E_P) + perror ("\nOS errmsg"); + else + eprintf ("\n"); + eprintf ("Fatal logout error. CL dies.\n"); + clexit(); + } + + /* Perform any ONERROR error recovery in the vos first. Initialize + * the error recovery mechanism (necessary since the iraf main is not + * being allowed to do error recovery). + */ + c_xonerr (1); + XER_RESET(); /* TODO: move into LIBC interface */ + + /* Clear terminal raw mode if still set. */ + c_fseti ((XINT)STDIN, F_RAW, NO); + + if (firstask->t_flags & T_BATCH) + eprintf ("\n[%d] ", bkgno); + if (errtype & E_IERR) + eprintf ("INTERNAL "); + if (errtype & E_FERR) + eprintf ("FATAL "); + if (currentask->t_flags & T_SCRIPT) + eprintf ("ERROR on line %d: ", currentask->t_scriptln); + else + eprintf ("ERROR: "); + + u_doprnt (diagstr, &args, currentask->t_stderr); + if (errtype & E_P) + perror ("\nOS errmsg"); + else + eprintf ("\n"); + + /* Log the error message if from a script or an executable. + */ + if (!errlog && keeplog() && log_errors()) + if (currentask->t_flags & T_SCRIPT || currentask->t_pid != -1) { + PKCHAR buf[SZ_LINE+1]; + FILE *fp; + int fd; + + fd = c_stropen (buf, SZ_LINE, NEW_FILE); + fp = fdopen (fd, "w"); + + fprintf (fp, "ERROR: "); + u_doprnt (diagstr, &args, fp); + + fclose (fp); + c_close (fd); + putlog (currentask, c_strpak (buf, (char *)buf, SZ_LINE)); + } + errlog = 0; + + /* Initialize the current command block but do not log the command + * which aborted. + */ + yy_startblock (NOLOG); + + /* Delete all pipefiles. Call iofinish() first as some OS's may + * require that the files be closed before they can be deleted. + */ + for (tp=currentask; !(tp->t_flags & T_INTERACTIVE); tp=next_task(tp)) { + iofinish (tp); + if (tp == firstask) + break; + } + delpipes (0); + + /* Do not go on if this is a fatal error or we are unattended. + */ + if (errtype & E_FERR) { + nfatal++; + pr_dumpcache (0, break_locks); + clexit(); + } else if (firstask->t_flags & T_BATCH) + clshutdown(); + + /* Reset state variables. */ + /* Most of these probably needn't be reset, but we'll play + * it safe. + */ + nestlevel = 0; /* Set nesting to 0. */ + offsetmode (0); /* Offset mode to index. */ + ncaseval = 0; /* Number of case values. */ + n_indexes = 0; + imloopset = 0; /* In an implicit loop. */ + n_oarr = 0; /* Implicit loop indicators. */ + i_oarr = 0; + maybeindex = 0; /* sexagesimal/index range */ + parse_state = PARSE_FREE; + if (last_parm) { /* Have we tried to add a param */ + last_parm->p_np = NULL; + currentask->t_pfp->pf_lastpp = last_parm; + last_parm = NULL; + } + + + /* Get back to an interactive state. + */ + taskunwind(); + + /* If an abort occurs while interrupts are disabled they will never get + * reenabled unless we do so here. + */ + intr_reset(); + + /* Go back to main loop in main(). + */ + va_end (args); + longjmp (errenv, 1); +} diff --git a/pkg/cl/errs.h b/pkg/cl/errs.h new file mode 100644 index 00000000..d7b26404 --- /dev/null +++ b/pkg/cl/errs.h @@ -0,0 +1,52 @@ +/* + * ERRS.H -- Type codes for first arg to error(). see errs.c. + * Just use bits for easy testing. if the type is or'd with E_P, + * then the systems own error info will also be printed by error(). + * Also declare the external diagnostic strings. + * + * E_UERR is a normal user diagnostic. + * E_IERR is an internal consistency check failure or system error. + * E_FERR is a fatal internal error. it causes error() to call shutdown(). + * E_P or-ed in causes call to perror() to print system error message. + */ + +#define E_UERR 001 +#define E_IERR 002 +#define E_FERR 004 +#define E_P 01000 + + +/* The diagnostic strings. defined in errs.c. + */ +extern char *e_appopen; +extern char *e_badstrop; +extern char *e_badsw; +extern char *e_edom; +extern char *e_erange; +extern char *e_fpe; +extern char *e_geonearg; +extern char *e_indexunf; +extern char *e_nominmax; +extern char *e_nopfile; +extern char *e_badpfile; +extern char *e_nostrcnv; +extern char *e_notbool; +extern char *e_onearg; +extern char *e_pambig; +extern char *e_pckambig; +extern char *e_pcknonexist; +extern char *e_posargs; +extern char *e_pnonexist; +extern char *e_ropen; +extern char *e_simplep; +extern char *e_strplusreal; +extern char *e_soverflow; +extern char *e_sunderflow; +extern char *e_tambig; +extern char *e_tnonexist; +extern char *e_twoargs; +extern char *e_unlink; +extern char *e_uopcode; +extern char *e_wopen; +extern char *e_fdivzero; +extern char *e_idivzero; diff --git a/pkg/cl/exec.c b/pkg/cl/exec.c new file mode 100644 index 00000000..efbd98bb --- /dev/null +++ b/pkg/cl/exec.c @@ -0,0 +1,1281 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#define import_xwhen +#include + +#include "config.h" +#include "clmodes.h" +#include "mem.h" +#include "opcodes.h" +#include "operand.h" +#include "param.h" +#include "task.h" +#include "errs.h" +#include "grammar.h" +#include "proto.h" + + +/* + * EXEC -- Functions that prepare tasks for running, the actual runtime + * interpreter, and functions involved in wrapping up when a task dies. + */ + +extern int cldebug; +extern int cltrace; + +#define SZ_STARTUPMSG 4000 /* cmd sent to subprocess to run task */ +#define BINDIR "bin$" /* where installed executables go */ + +extern FILE *yyin; /* yyparse's input */ +extern int alldone; /* set when oneof pops firstask */ +extern int yeof; /* parser saw EOF */ +extern int gologout; /* user typed logout() */ +extern int loggingout; /* in the process of logging out */ + +char *findexe(); + + +/* RUN -- Run the code beginning at pc until we run an EXEC instruction of + * something other than a builtin command or END instruction. + * The EXEC instruction means that a new task is being started and we should + * return to the parser in the main "parse/run" loop in main. If, however, + * the exec was for a builtin (or procedure, someday) then no parsing is to + * be done and we just continue on with the current code. + * Note that execing the bye builtin is not a special case since it does a + * restor() which resets the pc to the instruction immediately following the + * exec IN THE PARENT task and we continue on with it. + * Increment pc after each "fetch" cycle and before the "exec" cycle. + * If any if the instructions fail, they will call error(). this will do + * a longjmp(errenv,1), causing setjmp to return (in main) and an + * immediate retreat to the most recent terminaltask with unwind(). + */ +void +run (void) +{ + register struct codeentry *cp; + register int opcode; + + if (cltrace) + eprintf ("\t----- task %s -----\n", + currentask->t_ltp->lt_lname); + + do { + cp = coderef (pc); + opcode = cp->c_opcode; + if (cltrace) + d_instr (stderr, "\t", pc); + if (cldebug) + eprintf ("run: pc = %d, opcode = %d\n", pc, opcode); + pc += cp->c_length; + (*opcodetbl[opcode]) (&cp->c_args); + + } until ((opcode == EXEC && !(newtask->t_flags & T_BUILTIN)) || + opcode == END || alldone); +} + + +/* CALLNEWTASK -- Called from CALL instruction to push and setup a new task + * structure. If find a known ltask with given name create a new task on + * control stack, set up newtask and defaults for the pseudofiles. + * Pseudofiles may be effected by other instructions before it gets to exec. + * Make sure we have a pfile list; either try to read it if task is + * supposed to have a real one or manufacture the beginnings of one if it + * isn't and set PF_FAKE. New task runs with a copy of the pfile if it + * wasn't fake. Guard against making more than one copy. Also, don't dup + * the cl's params to maintain the meaning of "firstask". Things like mode, + * logfile and abbreviations should be global and permanent. + * Special case for package names essentially runs a cl but with a new curpack, + * the only real semantic intent of "running" a package. + * This lets a package name given as a command appear to change the current + * package and yet remain interactive. Since it really is a new task, state + * saving and restoring on error will work right and we also achieve an + * ability to have multiple package defn's in a script ltask. + * Any parameter references will refer to the cl's also. + */ +void +callnewtask ( + char *name +) +{ + /* x1 and x2 are just place holders to call breakout(). + */ + char *x1, *pk, *t, *x2; + struct ltask *ltp; + int flags, ltflags; + + if (cldebug) + eprintf ("callnewtask: name=%s, currentask=%x\n", name, currentask); + + /* Save current dictionary and stack pointers. they get restored when + * the new task dies normally and the current task is to continue. + * save pc when get to the EXEC instruction so it continues from there. + */ + currentask->t_topos = topos; /* save these two just in case */ + currentask->t_basos = basos; /* something is left on the stk */ + currentask->t_topcs = topcs; /* save before adding newtask */ + currentask->t_topd = topd; /* save before adding pfile */ + currentask->t_curpack = curpack;/* save in case changing to a new one*/ + c_envmark (¤task->t_envp);/* save env stack pointer */ + currentask->t_pno = 0; /* set only if task defines pkg */ + + newtask = pushtask(); + flags = 0; + + /* Search for the command to run. A leading '$' signifies that + * execution is to be time but is not part of the name. Set ltp + * and newtask->t_pfp depending on whether we are running a task or + * a package. + */ + if (*name == '$') { + flags |= T_TIMEIT; + name++; + } + + breakout (name, &x1, &pk, &t, &x2); + ltp = cmdsrch (pk, t); + + if (ltp->lt_flags & LT_CL) { + /* Change curpack if LT_PACCL. (cmdsrch() set lt_pkp). Just + * changing packages; use cl's ltask and pfile. Push a new cl() + * on the control stack, with the T_PKGCL and T_CL flags set. + */ + if (ltp->lt_flags & LT_PACCL) { + flags |= T_PKGCL; + curpack = ltp->lt_pkp; + } else if (ltp->lt_flags & LT_CLEOF) + flags |= T_CLEOF; + + ltp = firstask->t_ltp; + newtask->t_pfp = firstask->t_pfp; + + /* Initialize the lexical analyzer (necessary to recognize BOL). + */ + lexinit(); + + } else { + if (ltp->lt_flags & LT_PFILE) { + register struct pfile *pfp; + + /* This task has a real pfile. read in if not already in + * core. Copy if not already one and not just cl. + */ + newtask->t_pfp = NULL; + if ((pfp = pfilefind (ltp)) == NULL) + pfp = pfileload (ltp); + if (!(pfp->pf_flags & PF_COPY) && ltp != firstask->t_ltp) + pfp = pfilecopy (pfp); + newtask->t_pfp = pfp; + + /* Also load any pset files associated with the main pfile. + * These are linked into a list with the main pfile at the + * head of the list, pointed to by the task descriptor. + */ + if (pfp->pf_flags & PF_PSETREF) { + register struct param *pp; + struct operand o; + char *pset; + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + if (!(pp->p_type & PT_PSET)) + continue; + o = pp->p_valo; + if (opundef(&o) || *(pset = o.o_val.v_s) == EOS) + pset = pp->p_name; + pfp = pfp->pf_npset = pfilecopy (pfilesrch (pset)); + pfp->pf_psetp = pp; + } + } + + } else { + /* This task does not have a real pfile so start a fake one. + */ + newtask->t_pfp = newpfile (ltp); + newtask->t_pfp->pf_flags = PF_FAKE; + } + } + + newtask->t_pfp->pf_n = 0; /* init number of command line args */ + newtask->t_ltp = ltp; + newtask->t_pid = -1; /* gets set if do a real exec */ + newtask->t_stdin = currentask->t_stdin; /* inherit files */ + newtask->t_stdout = currentask->t_stdout; + newtask->t_stderr = currentask->t_stderr; + newtask->t_stdgraph = currentask->t_stdgraph; + newtask->t_stdimage = currentask->t_stdimage; + newtask->t_stdplot = currentask->t_stdplot; + + /* Init i/o redirection for a foreign task. + */ + newtask->ft_in = newtask->ft_out = newtask->ft_err = NULL; + + /* Set up flags describing the kind of task we are about to run. the + * absence of any of these flags will imply a genuine executable task. + * the flags in t_flags are more of a convenience than anything since + * later tests could use the same tests used here. + */ + ltflags = ltp->lt_flags; + + if (ltflags & LT_PSET) { + flags = (T_SCRIPT|T_PSET); + } else if (ltflags & LT_SCRIPT) { + newtask->t_scriptln = 0; + flags = T_SCRIPT; + } else if (ltflags & LT_FOREIGN) { + flags = T_BUILTIN | T_FOREIGN; /* a type of builtin */ + } else if (ltflags & LT_BUILTIN) { + flags = T_BUILTIN; + } else if (ltflags & LT_CL) { + /* Or, not assign: preserve T_PKGCL and T_CLEOF flags if set. */ + flags |= T_CL; + } + + if (ltflags & LT_STDINB) + flags |= T_STDINB; + if (ltflags & LT_STDOUTB) + flags |= T_STDOUTB; + + newtask->t_flags = flags; +} + + +/* EXECNEWTASK -- Called from the EXEC instruction after all param and stdio + * processing for the new task is complete. Here we actually run the new task, + * either directly in the case of a builtin function, or as a new case for + * main()'s loop. Do not set newtask to NULL so that run() can tell what it + * exec'd. + */ +void +execnewtask (void) +{ + /* VMS C V2.1 cannot handle this (see below). + * register struct pfile *pfp; + */ + static struct pfile *pfp; + + struct param *pp; + FILE *fopen(); + + if (newtask == NULL) + /* if this ever happens, i don't want to know about it. */ + return; + + currentask->t_pc = pc; /* instruction after EXEC */ + + if (cldebug) + eprintf ("execnewtask: pc = %d\n", pc); + + if (newtask->t_flags & T_BUILTIN) { + /* set yyin in case a builtin reads someday; none do now. + * unlink newtask's fake param file and reset top of dictionary + * to what it was before the fake param file was added; it is + * still there, however, for the builtin to use. this is done + * since some builtins (eg task) want to add things that are + * to stay on the dictionary and the tools all start at topd. + * the return is back to run(); it will continue since it will + * see that newtask was just a builtin. + * note that we do not reset pf_n, as with other fake pfiles, + * as this is the way builtins get their number of arguments + * (it's faster than building them a $nargs). + */ + yyin = newtask->t_in = currentask->t_in; /* inherit pipe */ + newtask->t_out = currentask->t_out; + newtask->t_modep = currentask->t_modep; /* inherit mode */ + + /* VMS C 2.1 Optimizer cannot handle this. + * parhead = dereference (reference (pfile, parhead)->pf_npf); + */ + pfp = reference (pfile, parhead); + parhead = dereference (pfp->pf_npf); + + topd = currentask->t_topd; + currentask = newtask; + newtask->t_flags |= T_RUNNING; + + if (cldebug) + eprintf ("execnewtask: calling new task@%x\n", newtask); + if (cltrace) + eprintf ("\t----- exec %s %s -----\n", + (newtask->t_flags & T_FOREIGN) ? "foreign" : "builtin", + newtask->t_ltp->lt_lname); + + (*newtask->t_ltp->lt_f)(); + oneof(); /* proceed as though this task saw eof */ + return; + } + + pfp = newtask->t_pfp; + + /* If the new task is a cl, we are not running in background and + * its t_in is stdin, it is interactive. Note that when a package + * is loaded by a script task rather than interactively by the user, + * the t_in of the cl() in the package script task will be reading + * from the calling script task rather than from the original stdin + * (the user terminal), hence is not interactive. If this task is + * flagged interactive, taskunwind() may elect to restart it on an + * error so save present state for restor(). + */ + if (newtask->t_flags & T_CL) { + if (cldebug) + eprintf ("execnewtask: new task is the CL\n"); + if (cltrace) + eprintf ("\t----- exec cl -----\n"); + + /* Call set_clio to set the command input and output streams + * t_in and t_out for a cl() or package_name() command. + */ + set_clio (newtask); + + /* This code is a temporary patch to allow packages to be + * loaded from within scripts regardless of whether there + * are enclosing brackets. If a CL statement is executed + * within a script which is itself called within another + * script, then we will do an implicit keep before the CL. + */ + if (topcs + 2*TASKSIZ <= STACKSIZ) + if ((strcmp (newtask->t_ltp->lt_lname, "cl") == 0) || + (strcmp (newtask->t_ltp->lt_lname, "clbye") == 0)) + if ((currentask->t_flags & T_SCRIPT) && + (prevtask->t_flags & T_SCRIPT)) + keep(prevtask); + + /* If newtask is cleof(), close the input stream of the current + * task (the task whose input contained the cleof), and reopen + * as the null file. + */ + if (newtask->t_flags & T_CLEOF) { + if (currentask->t_in != stdin) + fclose (currentask->t_in); + if (currentask != firstask) + currentask->t_in = fopen ("dev$null", "r"); + } + + if (!(firstask->t_flags & T_BATCH) && + (newtask->t_in == stdin) && (newtask->t_out == stdout)) { + newtask->t_flags |= T_INTERACTIVE; + newtask->t_topd = topd; + newtask->t_topos = topos; + newtask->t_topcs = topcs; + newtask->t_curpack = curpack; + } + } + + /* Standardize the pfile. + * Set (or create if necessary) `$nargs', number of command line args, + * based on pf_n which is set for each command line argument by + * posargset, et al. + * If this ltask had no paramfile and we built one up from the + * command line, then we need to add a `mode' param. If it did have + * a paramfile, then pfileload has already added it for us. + * Point t_modep to the mode param for newtask. + */ + pp = paramfind (pfp, "$nargs", 0, YES); + if (pp == NULL || (XINT)pp == ERR) { + char nabuf[FAKEPARAMLEN]; + sprintf (nabuf, "$nargs,i,h,%d\n", pfp->pf_n); + pp = addparam (pfp, nabuf, NULL); + pp->p_mode |= M_FAKE; /* never flush out $nargs */ + } else + pp->p_val.v_i = pfp->pf_n; + + if (pfp->pf_flags & PF_FAKE) { + newtask->t_modep = addparam (pfp, "mode,s,h,q\n", NULL); + /* pf_n will be used by paramsrch() to count positional arg + * matches; see it and param.h. + */ + pfp->pf_n = 0; + } else { + newtask->t_modep = paramfind (pfp, "mode", 0, YES); + } + + if (newtask->t_modep == NULL) + cl_error (E_IERR, "no mode param for task `%s'", + newtask->t_ltp->lt_lname); + + /* If task is being run in menu mode, call up eparam so that the user + * can edit/inspect the parameters. If eparam is exited with ctrl/c + * do not run the task or update the pfile. The parameter editor + * will make a copy of the task's pfile(s), edit it, and if necessary + * update the incore version created earlier by callnewtask(). + */ + if ((taskmode(newtask) & M_MENU) || (newtask->t_flags & T_PSET)) { + if (epset (newtask->t_ltp->lt_lname) == ERR) { + if (newtask->t_flags & T_PSET) + cl_error (E_UERR, "parameter file not updated"); + else + cl_error (E_UERR, "menu mode task execution aborted"); + } + } + + /* Set up bascode so new task has a good place to start building + * code. See how the pc is set up before each call to the parser in + * main() loop. + */ + newtask->t_bascode = topos + 1; + + /* Set up io paths. If the new task is cl(), it's command input + * and output streams are connected to those of the task which + * called currentask. If the currentask is the firstask, there + * was no caller (no prevtask), so we must watch out for that. + * In the case of a script, commands are read from the script. + * In the case of a process, commands are read from the process. + */ + if (newtask->t_flags & T_PSET) { + newtask->t_in = fopen ("dev$null", "r"); + newtask->t_out = newtask->t_stdout; + + } else if (newtask->t_flags & T_SCRIPT) { + if (cltrace) + eprintf ("\t----- exec script %s (%s) -----\n", + newtask->t_ltp->lt_lname, newtask->t_ltp->lt_pname); + + newtask->t_in = fopen (newtask->t_ltp->lt_pname, "r"); + if (newtask->t_in == NULL) + cl_error (E_UERR|E_P, "can not open script file `%s'", + newtask->t_ltp->lt_pname); + newtask->t_out = newtask->t_stdout; + + } else if (newtask->t_flags & T_CL) { + /* The command streams t_in and t_out have already been + * set up above by set_clio() in the test for T_INTERACTIVE. + */ + /* Do nothing */ + + } else { + char startup_msg[SZ_STARTUPMSG+1]; + int timeit; + + /* Connect to an executable process. + */ + mk_startupmsg (newtask, startup_msg, SZ_STARTUPMSG); + timeit = (newtask->t_flags & T_TIMEIT) != 0; + if (cltrace) + eprintf ("\t----- exec external task %s -----\n", + newtask->t_ltp->lt_lname); + newtask->t_pid = pr_connect ( + findexe (newtask->t_ltp->lt_pkp, newtask->t_ltp->lt_pname), + startup_msg, + &newtask->t_in, &newtask->t_out, + newtask->t_stdin, newtask->t_stdout, newtask->t_stderr, + newtask->t_stdgraph, newtask->t_stdimage, newtask->t_stdplot, + timeit); + } + + yyin = newtask->t_in; /* set the input for the parser */ + + /* Tell parser what to expect. + */ + parse_state = PARSE_FREE; + if (newtask->t_flags & T_SCRIPT) { + proc_script = (newtask->t_flags & T_PSET) ? NO : procscript(yyin); + + if (proc_script) { + parse_state = PARSE_BODY; + /* Skip to the BEGIN statement */ + newtask->t_scriptln = skip_to (yyin, "begin"); + if (newtask->t_scriptln == ERR) + cl_error (E_UERR, "No BEGIN statement in procedure script"); + + /* Reset pointer here. + */ + proc_script = NO; + } + } + + /* Log a start message for script and executable tasks. + */ + if (keeplog() && log_trace()) + if (newtask->t_flags & T_SCRIPT || newtask->t_pid != -1) { + char logmsg[SZ_LINE]; + sprintf (logmsg, "Start (%s)", newtask->t_ltp->lt_pname); + putlog (newtask, logmsg); + } + + newtask->t_flags |= T_RUNNING; + currentask = newtask; /* continue as new the new task; at last. */ + + if (cldebug) + eprintf ("Returning from execnewtask.yyin, ct_in, nt_in:%d %d %d\n", + yyin, currentask->t_in, newtask->t_in); +} + + +/* MK_STARTUPMSG -- Format the command to be sent to the interpreter in the + * IRAF Main in the child to execute the indicated logical task. The format + * of this command is + * + * taskname redir_args paramset_args + * + * where "redir_args" are used to either inform the task that a stream has + * been redirected by the CL (file "$") or to actually redirect a stream, + * and where "paramset_args" are assignments of the form "param=value". + * For example, "4 > $" tells the task that its standard output (4 = integer + * value of STDOUT) has been redirected. Only parameters with static values, + * i.e., with predefined values that are not expected to change during task + * execution (no queries) may be passed on the command line. + */ +void +mk_startupmsg ( + struct task *tp, /* task being executed */ + char *cmd, /* receives formatted command */ + int maxch /* max chars out */ +) +{ + register char *ip, *op, *cp; + struct pfile *pfp; + struct operand o; + struct param *pp; + char redir[20]; + + /* Start with the task name. + * Task names which begin with an underscore are used to implement + * "invisible" commands which are not intended to be part of the + * user interface. The distinction between these and regular + * commands is restricted to the CL, hence the leading underscore + * is stripped from the task name sent to the process. + */ + ip = tp->t_ltp->lt_lname; + while (*ip == CH_INVIS) + ip++; + strcpy (cmd, ip); + + /* Add redirection information. We can omit the pseudofile stream + * codes for the standard input and output as the iraf main will + * assume those streams if no stream code is given, though we must + * be explicit for stderr and the graphics streams. + */ + if (tp->t_flags & (T_MYIN|T_MYOUT|T_MYERR)) { + if (tp->t_flags & T_MYIN) + strcat (cmd, " < $"); + if (tp->t_flags & T_MYOUT) + strcat (cmd, " > $"); + if (tp->t_flags & T_MYERR) { + sprintf (redir, " %d> $", STDERR); + strcat (cmd, redir); + } + } + if (tp->t_flags & (T_MYSTDGRAPH|T_MYSTDIMAGE|T_MYSTDPLOT)) { + if (tp->t_flags & T_MYSTDGRAPH) { + sprintf (redir, " %d> $", STDGRAPH); + strcat (cmd, redir); + } + if (tp->t_flags & T_MYSTDIMAGE) { + sprintf (redir, " %d> $", STDIMAGE); + strcat (cmd, redir); + } + if (tp->t_flags & T_MYSTDPLOT) { + sprintf (redir, " %d> $", STDPLOT); + strcat (cmd, redir); + } + } + + for (cp=cmd; *cp; cp++) + --maxch; + + /* Add parameter assignments for all non list-structured parameters + * whose access would not cause a query, i.e., those parameters which + * already have a legal value and which are either hidden or were set + * on the command line. Passing the values of these parameters on the + * command line speeds task startup by reducing the number of parameter + * requests that must be processed by handshaking over the IPC. + */ + for (pfp = tp->t_pfp; pfp; pfp = pfp->pf_npset) { + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + o = pp->p_valo; + + /* Do not cache parameters which have an undefined value or + * for which the value is indirect to another parameter. + * Also, array parameters can not be cached currently. + */ + if (o.o_type & OT_UNDEF) + continue; + if ((o.o_type & OT_BASIC) == OT_STRING && + (o.o_val.v_s[0] == PF_INDIRECT)) + continue; + + if (pp->p_type & PT_ARRAY) + continue; + + if (!(pp->p_type & PT_LIST) && !(effmode(pp) & M_QUERY)) { + char buf[SZ_LINE+1]; + char val[SZ_LINE+1]; + + /* First format the param=value string in buf. + */ + + /* Start with "param=" if main pfile, or "pset.param=" if + * pset-param pfile. + */ + if (pfp->pf_psetp != NULL) { + ip = pfp->pf_psetp->p_name; + for (op=buf; (*op = *ip++); op++) + ; + *op++ = '.'; + } else + op = buf; + + for (ip=pp->p_name; (*op = *ip++); op++) + ; + *op++ = '='; + + /* Add "value". If the parameter is string valued enclose + * the string in quotes and convert any newlines into \n. + */ + sprop (val, &pp->p_valo); + if ((pp->p_type & OT_BASIC) == OT_STRING) + *op++ = '"'; + + for (ip=val; (*op = *ip++); op++) + if (*op == '\n') { + *op++ = '\\'; + *op = 'n'; + } else if (*op == '"') { + *op++ = '\\'; + *op = '"'; + } + + if ((pp->p_type & OT_BASIC) == OT_STRING) + *op++ = '"'; + + *op = EOS; + + /* Now check to see if there is room in the output buffer. + * If not we can just quit, as the task will automatically + * query for any parameters not set on the command line. + * If there is room break the current line by appending \\n + * (an escaped newline) and append the new line. + */ + maxch -= (strlen(buf) + 2); + if (maxch <= 0) + break; + + *cp++ = '\\'; + *cp++ = '\n'; + + for (ip=buf; (*cp = *ip++); cp++) + ; + } + } + } + + /* Terminate the command line by appending an unescaped newline. + */ + *cp++ = '\n'; + *cp = EOS; + + if (cldebug) + eprintf ("CALL %s", cmd); +} + + +/* FINDEXE -- Search a set of standard places for an executable file to be + * run. Currently, we check first in the logical directory BIN for the + * "installed" version of the executable, and if that is not found, use + * the pathname given, which is the pathname specified in the TASK declaration. + */ +char * +findexe ( + struct package *pkg, /* package in which task resides */ + char *pkg_path /* pathname of exe file given in TASK statement */ +) +{ + static char bin_path[SZ_PATHNAME+1], loc_path[SZ_PATHNAME+1]; + char root[SZ_FNAME+1], root_path[SZ_PATHNAME+1]; + char bindir[SZ_FNAME+1], *ip = NULL, *arch = NULL; + char bin_root[SZ_PATHNAME+1]; + char *envget(); + + + memset (root, 0, SZ_FNAME); + memset (bindir, 0, SZ_FNAME); + memset (bin_path, 0, SZ_PATHNAME); + memset (loc_path, 0, SZ_PATHNAME); + memset (bin_root, 0, SZ_PATHNAME); + memset (root_path, 0, SZ_PATHNAME); + + c_fnroot (pkg_path, root, SZ_FNAME); + c_fpathname ((pkg ? pkg->pk_bin : BINDIR), root_path, SZ_PATHNAME); + sprintf (bin_path, "%s%s.e", pkg ? pkg->pk_bin : BINDIR, root); + sprintf (loc_path, "./%s.e", root); + arch = envget ("arch"); + + + if (c_access (bin_path, 0, 0) == YES) { + return (bin_path); + } else { + /* The binary wasn't found in the expected bin directory, but + * on certain platforms look for alternate binaries that may + * work. This supports backward compatability with older + * packages that may not have been upgraded to architecture + * conventions in this release but which may contain usable + * binaries (e.g. 32-bit 'linux' binaries on 64-bit systems + * or older 'redhat' binaries where the core arch is 'linux'). + */ + memset (bin_root, 0, SZ_PATHNAME); + strcpy (bin_root, root_path); + if ((ip = strstr (bin_root, arch))) + *ip = '\0'; + else { + int len = strlen (bin_root); + if (bin_root[len-1] == '/') + bin_root[len-1] = '\0'; + } + + if (strcmp (arch, ".linux64") == 0) { + /* On 64-bit Linux systems we can use either of the + * available 32-bit binaries if needed. In v2.15 and + * later, 'linux' is the preferred arch but look for + * 'redhat' in case it's a package that hasn't been + * updated. + */ + sprintf (bin_path, "%s.linux/%s.e", bin_root, root); + if (c_access (bin_path, 0, 0) == YES) + return (bin_path); + + sprintf (bin_path, "%s.redhat/%s.e", bin_root, root); + if (c_access (bin_path, 0, 0) == YES) + return (bin_path); + + } else if (strcmp (arch, ".linux") == 0) { + /* On 32-bit Linux systems, check for older 'redhat' binaries. + */ + sprintf (bin_path, "%s.redhat/%s.e", bin_root, root); + if (c_access (bin_path, 0, 0) == YES) + return (bin_path); + + } else if (strcmp (arch, ".macintel") == 0) { + /* On 64-bit Mac systems, check for older 32-bin binaries. + */ + sprintf (bin_path, "%s.macosx/%s.e", bin_root, root); + if (c_access (bin_path, 0, 0) == YES) + return (bin_path); + + } else if (strcmp (arch, ".macosx") == 0) { + /* On 32-bit Mac systems, check for older 'macintel' binaries. + */ + sprintf (bin_path, "%s.macintel/%s.e", bin_root, root); + if (c_access (bin_path, 0, 0) == YES) + return (bin_path); + } + } + + if (c_access (pkg_path, 0, 0) == YES) + return (pkg_path); + else + return (loc_path); +} + + +/* SET_CLIO -- Set the command input and output for the new cl(). If the + * standard input or output has been redirected, use that, otherwise inherit + * the t_in, t_out of the task preceeding the most recent non-CL task that has + * the same t_in as the current task (this is not obvious, but permits packages + * to be called or loaded within scripts). In the case of a cl() type task + * used to change packages, change the current package and push a cl() on the + * control stack but continue reading from the current command stream. + */ +void +set_clio ( + register struct task *newtask +) +{ + register struct task *tp; + + if ((newtask->t_stdin == currentask->t_stdin) && + (currentask->t_in != stdin)) { + newtask->t_in = NULL; + + if (newtask->t_flags & T_PKGCL) { /* package() */ + newtask->t_in = currentask->t_in; + tp = currentask; + } else { /* cl() */ + for (tp=currentask; tp != firstask; tp = next_task(tp)) + if (!(tp->t_flags & T_CL) && + (tp->t_in == currentask->t_in)) { + tp = next_task(tp); + newtask->t_in = tp->t_in; + break; + } + } + if (newtask->t_in == NULL) + cl_error (E_IERR, "Cannot find t_in for cl()"); + + } else { /* pk|cl < */ + tp = NULL; + newtask->t_in = newtask->t_stdin; + } + + if ((newtask->t_stdout == stdout) && (tp != NULL)) + newtask->t_out = tp->t_out; + else + newtask->t_out = newtask->t_stdout; /* pk|cl > */ +} + + +/* PPFIND -- Search the list of loaded psets for a task for the named + * parameter. If a taskname is given, search only the pset with that + * taskname, else search all the psets associated with the running task. + * This is called by the routines in opcodes.c to perform command line + * assignments to parameters. + */ +struct param * +ppfind ( + struct pfile *pfp, /* first pfile in chain */ + char *tn, /* psetname (taskname) or null */ + char *pn, /* parameter name */ + int pos, /* for paramfind */ + int abbrev /* for paramfind */ +) +{ + struct param *pp, *m_pp; + struct pfile *m_pfp; + int nchars; + + if (tn != NULL && *tn != EOS) { + /* Locate the named pset and search it. */ + for (nchars=strlen(tn), m_pp=NULL; pfp; pfp = pfp->pf_npset) { + if ((pp = pfp->pf_psetp)) { + if (strncmp (pp->p_name, tn, nchars) == 0) { + if (strlen (pp->p_name) == nchars) + return (paramfind (pfp, pn, pos, abbrev)); + else if (m_pp) + return ((struct param *)ERR); + else { + m_pp = pp; + m_pfp = pfp; + } + } + } + } + + /* Unique abbreviation for pset was given. */ + if (m_pp) + return (paramfind (m_pfp, pn, pos, abbrev)); + else + return (NULL); + + } else { + /* Search all psets. */ + for (; pfp; pfp = pfp->pf_npset) + if ((pp = paramfind (pfp, pn, pos, abbrev)) != NULL) + return (pp); + return (NULL); + } +} + + +/* PSETRELOAD -- Called when a pset parameter is assigned into by a command + * line argument. The previous value of the pset param will already have + * been used by callnewtask() to load a pset. We must replace the old pset + * by the new one. + */ +void +psetreload ( + struct pfile *main_pfp, /* main task pfile */ + struct param *psetp /* pset param */ +) +{ + struct pfile *o_pfp, *n_pfp, *prev_pfp, *next_pfp; + + if (cldebug) + eprintf ("psetreload, pset %s\n", psetp->p_name); + + /* Locate the old pfile in the list of psets off the main task pfile. + */ + prev_pfp = main_pfp; + for (o_pfp=prev_pfp->pf_npset; o_pfp; o_pfp = o_pfp->pf_npset) + if (o_pfp->pf_psetp == psetp) + break; + else + prev_pfp = o_pfp; + + if (o_pfp == NULL) + cl_error (E_IERR, "in psetreload: cannot find npset"); + else + next_pfp = o_pfp->pf_npset; + + /* Unlink the old pfile and its copy. This must be done before loading + * the new pfile, else pfilesrch will simply reference the old pfile. + */ + pfileunlink (o_pfp->pf_oldpfp); + pfileunlink (o_pfp); + + /* Load the new pfile. */ + n_pfp = pfilecopy (pfilesrch (psetp->p_name)); + + /* Link it into the pset list */ + prev_pfp->pf_npset = n_pfp; + n_pfp->pf_npset = next_pfp; + n_pfp->pf_psetp = o_pfp->pf_psetp; +} + + +/* IOFINISH -- Flush out and wrap up all pending io for given task. + * Called when the task is dying and it wants to close all files it opened. + * This includes a pipe if it used one, a file if it was a script and io + * redirections as indicated by the T_MYXXX flags. The T_MYXXX flags are + * set only when the redirections were done for this task, ie, they were + * not simply inherited. + * Just as a fail-safe measure, always check that a real stdio file is + * not being closed. + * Don't call error() because in trying to restor to an interactive task + * it might call us again and cause an inf. loop. + */ +void +iofinish ( + register struct task *tp +) +{ + register FILE *fp; + int flags; + + flags = tp->t_flags; + + /* Make sure we do not close files more than once. + */ + if (flags & T_RUNNING) + tp->t_flags &= ~T_RUNNING; + else + return; + + if (cldebug) + eprintf ("flushing io for task `%s'\n", tp->t_ltp->lt_lname); + + if (flags & T_MYIN) { + fp = tp->t_stdin; + if (fp != stdin) + fclose (fp); + } + if (flags & T_MYOUT) { + fflush (fp = tp->t_stdout); + if (fp != stdout) + fclose (fp); + } + if (flags & T_MYERR) { + fflush (fp = tp->t_stderr); + if (fp != stderr) + fclose (fp); + } + + /* Close any redirected graphics output streams. + */ + if (flags & (T_MYSTDGRAPH|T_MYSTDIMAGE|T_MYSTDPLOT)) { + if (flags & T_MYSTDGRAPH) + if (tp->t_stdgraph != tp->t_stdimage && + tp->t_stdgraph != tp->t_stdplot) + fclose (tp->t_stdgraph); + if (flags & T_MYSTDIMAGE) + if (tp->t_stdimage != tp->t_stdplot) + fclose (tp->t_stdimage); + if (flags & T_MYSTDPLOT) + fclose (tp->t_stdplot); + } + + /* If task i/o is redirected to a subprocess send the done message. + */ + if (flags & T_IPCIO) + fputs (IPCDONEMSG, tp->t_out); + fflush (tp->t_out); + + /* Close files only for script task, not for a cl, a builtin, or + * a process. Do call disconnect if the task lives in a process. + */ + if (flags & T_SCRIPT) { + fp = tp->t_in; + if (fp != stdin) + fclose (fp); + } else if (flags & (T_CL|T_BUILTIN)) { + ; + } else if (tp->t_pid != -1) + pr_disconnect (tp->t_pid); + + /* Log a stop message for script and executable tasks. + */ + if (keeplog() && log_trace()) + if (tp->t_flags & T_SCRIPT || tp->t_pid != -1) + putlog (tp, "Stop"); +} + + +/* RESTOR -- Restor all global variables for the given task and insure the + * integrity of the dictionary and control stack. + * Go through the dictionary and properly disgard any packages, ltasks, + * pfiles, environments and params that may be above the new topd. + * Write out any pfiles that are not just working copies that have been + * updated before discarding them. + * Don't call error() because in trying to restor to an interactive task + * it might call us again and cause an inf. loop. Instead, issue fatal error + * which will kill the cl for good. This seems reasonable since we might + * as well die if we can't restor back to an interactive state. + * N.B. we assume that a pfile's params will either all lie above or all + * below tp->t_topd. If this can ever happen, must add a further check + * of each pfile below topd and lob off any params above topd. + * The way posargset, et al, and call/execnewtask are now, we are safe. + */ +void +restor ( + struct task *tp +) +{ + memel *topdp; + register struct ltask *ltp; + register struct package *pkp; + register struct param *pp; + register struct pfile *pfp; + struct param *last_pp; + int n; + + if (cldebug) { + eprintf ("restoring task `%s', tp: %d\n", tp->t_ltp->lt_lname,tp); + eprintf (" topd %d/%d\n", topd, tp->t_topd); + } + + topd = tp->t_topd; + pc = tp->t_pc; + topos = tp->t_topos; + basos = tp->t_basos; + topcs = tp->t_topcs; + curpack = tp->t_curpack; + + yyin = tp->t_in; + parse_state = PARSE_FREE; + + topdp = daddr (topd); + + /* Set pachead to first package below new topd. Then lob off any ltasks + * all remaining packages might have above topd. It is sufficient to + * stop the ltask checks for a given package once find an ltask + * below topd since the dictionary always grows upward. + * (Recall that since new ltasks are always added at the top of the + * dictionary, and pkp->pk_ltp always points to the most recently + * added ltask, then the thread moves to lower and lower addrs.) + * Thus, work downward and throw out all ltasks until find one below + * the new topd. + */ + for (pkp = reference (package, pachead); pkp; pkp = pkp->pk_npk) + if ((memel)pkp < (memel)topdp) { + pachead = dereference (pkp); + break; + } + if (pkp == NULL) + cl_error (E_FERR, "package list broken"); + + for (; pkp; pkp = pkp->pk_npk) { + for (ltp = pkp->pk_ltp; ltp; ltp = ltp->lt_nlt) + if ((memel)ltp < (memel)topdp) { + pkp->pk_ltp = ltp; + break; + } + if ((memel)pkp->pk_ltp >= (memel)topdp) + /* All ltasks in this package were above topd */ + pkp->pk_ltp = NULL; + } + + /* Similarly for pfiles and their params; however, since new params + * are always added at the top of the dictionary and linked in at the + * END of the list (at pfp->pf_lastpp), the thread off pfp->pf_pp + * moves to higher and higher addrs. Thus, we work our way up and + * throw out all params above the new topd. Also, close off any open + * list files from discarded params along the way, if any. + * Also, see if any of the params were P_SET and set PF_UPDATE. + * This avoids having to set PF_UPDATE for each assignment when the + * is not always easily found. + * N.B. hope mode param that some t_modep is using is never disgarded.. + * Also, guard against writing out pfiles in background. + */ + for (pfp = reference (pfile, parhead); pfp; pfp = pfp->pf_npf) { + /* Lob off any pfiles above new topd. Go through their + * params, updating if necessary and closing any lists. + */ + if ((memel)pfp < (memel)topdp) { + parhead = dereference (pfp); + break; + } + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + /* Close if list file and enable flushing if P_SET. + */ + if (pp->p_type & PT_LIST) + closelist (pp); + if (pp->p_flags & P_SET) + pfp->pf_flags |= PF_UPDATE; + } + if (((pfp->pf_flags & (PF_UPDATE|PF_COPY)) == PF_UPDATE) && + !(firstask->t_flags & T_BATCH)) + pfileupdate (pfp); + } + + /* Discard any recently added parameters above topd, where the pfile + * itself is below topd. This happens when a new parameter is added + * to an existing incore pfile, e.g., in a declaration. + */ + for (; pfp; pfp = pfp->pf_npf) { + if ((memel)(pfp->pf_lastpp) < (memel)topdp) + continue; /* quick check */ + last_pp = NULL; + n = 0; + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + if ((memel)pp >= (memel)topdp) { + if (cldebug) + fprintf (stderr, "chop pfile for task %s at param %s\n", + pfp->pf_ltp->lt_lname, last_pp->p_name); + if (last_pp) + last_pp->p_np = NULL; + pfp->pf_lastpp = last_pp; + pfp->pf_n = n; + break; + } else { + last_pp = pp; + n++; + } + } + } + + /* Delete any SET environment statements processed since this task + * was spawned. If any redefs are uncovered the original values are + * reset in all connected subprocesses. + */ + if (tp->t_envp) + c_prenvfree (0, tp->t_envp); + + /* If the task being restored defined a package, dump all processes + * in the process cache spawned since the package was loaded. + */ + if (tp->t_pno) + pr_prunecache (tp->t_pno); +} + + +/* ONEOF -- "on eof" (not "one of"): + * The current task has issued eof, either directly or via the "bye" command. + * Flush out all pending io, copy working pfile back to original if have one, + * pop a state back to the previous state and restore its environment. + * Avoid calling effecmode() if called from a builtin task since builtins + * do not have the "mode" parameter. + * + * If currentask is the first cl or we are batch, then we are truely done. + * Return true to the caller (EXECUTE), causing a return to the main. + */ +void +oneof (void) +{ + register struct pfile *pfp; + register struct package *pkp; + static int nerrs = 0; + int flags; + + if (cldebug) + eprintf ("received `%s' from `%s'\n", yeof ? "eof" : "bye", + currentask == firstask ? "root" : currentask->t_ltp->lt_lname); + + if (!(firstask->t_flags & T_BATCH)) + if (currentask == firstask && !gologout && !loggingout && + isatty (fileno (stdin)) && nerrs++ < 8) + cl_error (E_UERR, "use `logout' to log out of the CL"); + + flags = currentask->t_flags; + + if (!(flags & (T_BUILTIN|T_CL|T_SCRIPT|T_BATCH))) + fflush (currentask->t_out); + iofinish (currentask); + + /* Copy back the main pfile and any pset-param files. If the task + * which has terminated is a package script task, fix up the pfile + * pointer in the package descriptor to point to the updated pset. + */ + if (currentask->t_ltp->lt_flags & LT_PFILE) { + pfcopyback (pfp = currentask->t_pfp); + if (currentask->t_ltp->lt_flags & LT_DEFPCK) + if ((pkp = pacfind(currentask->t_ltp->lt_lname))) + if (pkp->pk_pfp == pfp) + pkp->pk_pfp = pfp->pf_oldpfp; + for (pfp = pfp->pf_npset; pfp != NULL; pfp = pfp->pf_npset) + pfcopyback (pfp); + } + + if (currentask == firstask) + alldone = 1; + else { + currentask = poptask(); + if (currentask->t_flags & T_BATCH) + alldone = 1; + } + + restor (currentask); /* restore environment */ +} + + +/* PRINTCALL -- Print the calling sequence for a task. Called by killtask() + * to print stack trace. + */ +void +printcall ( + FILE *fp, + struct task *tp +) +{ + register struct param *pp; + int notfirst = 0; + + fprintf (fp, " %s (", tp->t_ltp->lt_lname); + for (pp = tp->t_pfp->pf_pp; pp != NULL; pp = pp->p_np) + if (pp->p_flags & P_CLSET) { + if (notfirst) + fprintf (fp, ", "); + notfirst++; + if (!(tp->t_pfp->pf_flags & PF_FAKE) && !(pp->p_mode & M_FAKE)) + fprintf (fp, "%s=", pp->p_name); + + /* Use only low level routines to print the parameter value to + * avoid error recursion. In particular, parameter indirection + * is not resolved. + */ + if (!(pp->p_valo.o_type & OT_UNDEF)) + fprop (fp, &pp->p_valo); + else + fprintf (fp, "UNDEF"); + } + fprintf (fp, ")\n"); +} + + +/* KILLTASK -- Abort the currently executing task. Only call this when a task + * is to be killed spontaneously, as from interrupt, not when it is just dying + * due to a "bye" or eof. + * Close all pipes and pseudofiles, being careful not to close any that + * are real stdio files. + * Note that our function is to kill an external task, not the process in which + * it resides. The process is left running in the cache in case it is needed + * again. + */ +void +killtask ( + register struct task *tp +) +{ + char buf[128]; + + /* Print stack trace, with arguments. + */ + if (!(tp->t_ltp->lt_flags<_INVIS) && !(firstask->t_flags&T_BATCH) && + !(strcmp (tp->t_ltp->lt_lname, "error") == 0)) + printcall (currentask->t_stderr, tp); + + /* If task is running in a subprocess, interrupt it and read the ERROR + * message. Not certain there isn't some case where this could cause + * deadlock, but it does not seem so. Interrupts are disabled during + * process startup. If task issues ERROR then it is popped before + * we are called, without issuing the signal. + */ + if (tp->t_pid != -1) { + fflush (tp->t_out); + c_prsignal (tp->t_pid, X_INT); + fgets (buf, 128, tp->t_in); + } + + iofinish (tp); +} diff --git a/pkg/cl/globals.c b/pkg/cl/globals.c new file mode 100644 index 00000000..fb7f38de --- /dev/null +++ b/pkg/cl/globals.c @@ -0,0 +1,119 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "operand.h" +#include "construct.h" +#include "param.h" +#include "task.h" +#include "eparam.h" + + + +int parse_state; /* What are we parsing? */ +int proc_script; /* In a procedure script? */ +struct pfile *parse_pfile; /* Where parsed params are added. */ + +int nextdest[MAX_LOOP]; /* Destinations for NEXT's */ +int brkdest[MAX_LOOP]; /* Destinations for BREAK's */ + +int nestlevel = 0; /* Loop nesting level */ +int ncaseval; /* Number of cases in switch */ + +int n_oarr; /* Number of open array indices */ +int i_oarr; /* Current open array index */ + +int oarr_beg[N_OPEN_ARR]; /* Open index limits. */ +int oarr_end[N_OPEN_ARR]; +int oarr_curr[N_OPEN_ARR]; /* Current value for index. */ +int imloopset = 0; /* Loop inited at run time? */ +int n_indexes = 0; /* Number of indexes on stack. */ + +int maybeindex; /* Could last constant be index */ + /* range? */ + +struct label *label1 = NULL; /* Pointer to first top of label list. */ +int igoto1 = -1; /* Head of list of indirect GOTO's */ + +struct operand *parlist[MAX_PROC_PARAMS]; +struct param *last_parm; /* Last parameter before compilation. */ +int n_procpar; /* Number of params in proc stmt. */ + +/* Default initialization of the EDCAP editor command set. + * Note: these are expected to be reset be the edcap facility at runtime. + * The source of most of these defaults is the EMACS editor + */ +int numcommands; /* number of defined commands */ + +struct edit_commands command[MAX_COMMANDS] = { + { EDITOR_ID ,"\0" ,"" }, + { EDIT_INIT ,"\0" ,"enable" }, + { EDIT_TERM ,"\0" ,"disable" }, + + { MOVE_UP ,"\020" ,"^P" }, + { MOVE_DOWN ,"\016" ,"^N" }, + { MOVE_RIGHT ,"\006" ,"^F" }, + { MOVE_LEFT ,"\002" ,"^B" }, + + { MOVE_UP ,"\033\133\101" ,"UP ARROW" }, + { MOVE_DOWN ,"\033\133\102" ,"DOWN ARROW" }, + { MOVE_RIGHT ,"\033\133\103" ,"RIGHT ARROW" }, + { MOVE_LEFT ,"\033\133\104" ,"LEFT ARROW" }, + + { NEXT_WORD ,"\033\106" ,"ESC-F" }, + { NEXT_WORD ,"\033\146" ,"ESC-f" }, + { PREV_WORD ,"\033\102" ,"ESC-B" }, + { PREV_WORD ,"\033\142" ,"ESC-b" }, + { MOVE_EOL ,"\005" ,"^E" }, + { MOVE_BOL ,"\001" ,"^A" }, + { NEXT_PAGE ,"\026" ,"^V" }, + { PREV_PAGE ,"\033\126" ,"ESC-V" }, + { PREV_PAGE ,"\033\166" ,"ESC-v" }, + { MOVE_START ,"\033\074" ,"ESC-<" }, + { MOVE_END ,"\033\076" ,"ESC->" }, + + { SET_FWD ,"\000" ,"undefined" }, + { SET_AFT ,"\000" ,"undefined" }, + { TOGGLE_DIR ,"\000" ,"undefined" }, + + { DEL_LEFT ,"\177" ,"DEL" }, + { DEL_LEFT ,"\010" ,"^H or BS" }, + { DEL_CHAR ,"\004" ,"^D" }, + { DEL_WORD ,"\033\104" ,"ESC-D" }, + { DEL_WORD ,"\033\144" ,"ESC-d" }, + { DEL_LINE ,"\013" ,"^K" }, + { UNDEL_CHAR ,"\033\004" ,"ESC-^D" }, + { UNDEL_WORD ,"\033\027" ,"ESC-^W" }, + { UNDEL_LINE ,"\033\013" ,"ESC-^K" }, + + { FIND_FWD ,"\033\123" ,"ESC-S" }, + { FIND_FWD ,"\033\163" ,"ESC-s" }, + { FIND_AFT ,"\033\122" ,"ESC-R" }, + { FIND_AFT ,"\033\162" ,"ESC-r" }, + { FIND_NEXT ,"\000" ,"undefined" }, + + { GET_HELP ,"\033\077" ,"ESC-?" }, + { REPAINT ,"\014" ,"^L" }, + { EXIT_UPDATE ,"\032" ,"^Z" }, + { EXIT_NOUPDATE ,"\003" ,"^C" }, + + { NEXT_LINE ,"\000" ,"undefined" }, + { NOMORE_COMMANDS ,"\0" ,"" } +}; + +/* Names of the editor commands, used for edcap interpretation and showhelp. + */ +char *cmdnames[MAX_COMMANDS] = { + "EDITOR_ID", "EDIT_INIT", "EDIT_TERM", + "MOVE_UP", "MOVE_DOWN", "MOVE_RIGHT", "MOVE_LEFT", "NEXT_WORD", + "PREV_WORD", "MOVE_EOL", "MOVE_BOL", "NEXT_PAGE", "PREV_PAGE", + "MOVE_START", "MOVE_END", "SET_FWD", "SET_AFT", "TOGGLE_DIR", + "DEL_LEFT", "DEL_CHAR", "DEL_WORD", "DEL_LINE", "UNDEL_CHAR", + "UNDEL_WORD", "UNDEL_LINE", "FIND_FWD", "FIND_AFT", "FIND_NEXT", + "GET_HELP", "REPAINT", "EXIT_UPDATE", "EXIT_NOUPDATE", + "NEXT_LINE", "NOMORE_COMMANDS" +}; diff --git a/pkg/cl/gquery.c b/pkg/cl/gquery.c new file mode 100644 index 00000000..6c6a9f03 --- /dev/null +++ b/pkg/cl/gquery.c @@ -0,0 +1,207 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "config.h" +#include "operand.h" +#include "param.h" +#include "grammar.h" +#include "task.h" +#include "clmodes.h" +#include "proto.h" + + +/* Contains modified portions of modes.c for range checking etc. for use + * by EPARAM. The problem with modes.c is that it not only checks ranges, + * but does direct i/o to the terminal. + */ + +extern int cldebug; +static char *e1 = "Not in batch"; +static char *e2 = "Parameter value is out of range"; + + +/* GQUERY -- Determine if the value of a parameter given by the user is OK. + * Also, store the new value in the parameter; in the case of a list + * structured parameter, the new value is the name of a new list file. + * This routine is called by EPARAM to verify that the new parameter value + * is inrange and set the new value if so. + */ +char * +gquery ( + struct param *pp, + char *string +) +{ + register char *ip; + char buf[SZ_LINE]; + char *query_status, *nlp, *errmsg; + int arrflag, offset, bastype, batch; + struct operand o; + char *strcpy(), *index(); + + bastype = pp->p_type & OT_BASIC; + batch = firstask->t_flags & T_BATCH; + arrflag = pp->p_type & PT_ARRAY; + + if (arrflag) + offset = getoffset(pp); + + if (batch) { + errmsg = e1; + return (errmsg); + } else + query_status = strcpy (buf, string); + + ip = buf; + + /* Set o to the current value of the parameter. Beware that some + * of the logical branches which follow assume that struct o has + * been initialized to the current value of the parameter. + */ + if (pp->p_type & PT_LIST) { + setopundef (&o); + } else if (arrflag) { + poffset (offset); + paramget (pp, FN_VALUE); + o = popop (); + } else + o = pp->p_valo; + + /* Handle eof, a null-length line (lone carriage return), + * and line with more than SZ_LINE chars. Ignore leading whitespace + * if basic type is not string. + */ + if (query_status == NULL) + goto testval; + + /* Ignore leading whitespace if it is not significant for this + * datatype. Do this before testing for empty line, so that a + * return such as " \n" is equivalent to "\n". I.e., do not + * penalize the user if they type the space bar by accident before + * typing return to accept the default value. + */ + if (bastype != OT_STRING || (pp->p_type & PT_LIST)) + while (*ip == ' ' || *ip == '\t') + ip++; + + if (*ip == '\n') { + /* Blank lines usually just accept the current value + * but if the param in a string and is undefined, + * it sets the string to a (defined) nullstring. + */ + if (bastype == OT_STRING && opundef (&o)) { + *ip = '\0'; + o = makeop (ip, bastype); + } else + goto testval; + } + + /* Cancel the newline. */ + if ((nlp = index (ip, '\n')) != NULL) + *nlp = '\0'; + + /* Finally, we have handled the pathological cases. + */ + if (pp->p_type & PT_LIST) + o = makeop (string, OT_STRING); + else + o = makeop (ip, bastype); + +testval: + if (*string == '@') + errmsg = "OK"; + else if (pp->p_type & PT_LIST) + errmsg = "OK"; + else if (inrange (pp, &o)) + errmsg = "OK"; + else { + errmsg = e2; + return (errmsg); + } + + if (cldebug) { + eprintf ("changing `%s.p_val' to ", pp->p_name); + fprop (stderr, &o); + eprintf ("\n"); + } + + /* Update param with new value. + */ + pushop (&o); + if (arrflag) + poffset (offset); + + paramset (pp, FN_VALUE); + pp->p_flags |= P_SET; + + return ("OK"); +} + + +/* MINMAX -- Format the minimum and maximum values of a parameter, if any. + */ +char * +minmax ( + register struct param *pp +) +{ + static char message[SZ_LINE]; + + /* Show the ranges if they are defined and this is a parameter + * type that has ranges. + */ + if (range_check (pp)) { + char str[SZ_LINE]; + struct operand o; + + o.o_type = pp->p_type & OT_BASIC; + + sprintf (message, " (minimum="); + if (!(pp->p_flags & (P_IMIN|P_UMIN))) { + o.o_val = pp->p_min; + sprop (str, &o); + strcat (message, str); + } + strcat (message, ": maximum="); + if (!(pp->p_flags & (P_IMAX|P_UMAX))) { + o.o_val = pp->p_max; + sprop (str, &o); + strcat(message, str); + } + strcat (message, ")"); + } else + message[0] = EOS; + + return (message); +} + + +/* ENUMIN -- Format the enumeration string for a parameter. + */ +char * +enumin ( + register struct param *pp +) +{ + static char message[SZ_LINE]; + + if (!(pp->p_flags & (P_IMIN|P_UMIN))) { + char str[SZ_LINE]; + struct operand o; + + sprintf (message, " choose: "); + + o.o_type = pp->p_type & OT_BASIC; + o.o_val = pp->p_min; + sprop (str, &o); + strcat (message, str); + } else + message[0] = EOS; + + return (message); +} diff --git a/pkg/cl/gram.c b/pkg/cl/gram.c new file mode 100644 index 00000000..2ab01f15 --- /dev/null +++ b/pkg/cl/gram.c @@ -0,0 +1,1364 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "config.h" +#include "clmodes.h" +#include "operand.h" +#include "mem.h" +#include "grammar.h" +#include "opcodes.h" +#include "param.h" +#include "task.h" +#include "errs.h" +#include "construct.h" +#include "ytab.h" /* pick up yacc token #defines */ +#include "proto.h" + + +/* + * GRAM -- These routines are used by the parser and lex files grammar.y and + * grammar.l. Also we handle other things that are very visible to the user + * here too, such as cracking and running the intrinsic functions. + * + * We define our own yywrap() here to set yeof. + * TODO: clean up having to keep some of the strings upper, some lower case. + */ + +#define SZ_PIPEFILENAME (6+4+5) /* uparm$ // pipe // XXXXX */ +#define MAX_PIPECODE 30000 /* modulus for pipecodes */ + +int yeof; /* set by yywrap when it sees eof. */ +extern int yylval; /* declared in y.tab.c */ +extern int cldebug; + +extern int inarglist; /* set by parser when in argument list */ +extern int parenlevel; /* nesting level of parens */ +extern int get_nscanval(); +int pipetable[MAXPIPES]; /* for maintaining pipe temp files */ +int nextpipe = 0; + +char *truestr = "yes"; /* true constant as it appears in ASCII */ +char *falsestr = "no"; /* false " */ +char *nullstr = ""; +char *undefval = ""; /* used in nextfield(), pvaldefined() */ +char *indefstr = "INDEF"; /* input or output for indef operands */ +char *indeflc = "indef"; /* lower case version. */ +char *eofstr = "EOF"; /* list file EOF or input */ +char *eoflc = "eof"; /* lower case version */ +char *epsilonstr="epsilon"; /* a small value; see config.h */ +char *errorstr = "error"; /* the error statement */ +char *err_cmdblk; /* Pointer where error detected */ +extern char cmdblk[SZ_CMDBLK+1]; /* current command block (in history.c) */ + + +/* Usually the following routine is provided by the yacc library but we need + * our own here to signal the parser that an eof has been read. + */ +int +yywrap (void) +{ + yeof = 1; + return (1); +} + +/* Yacc calls this when it gets a general error. We are doing all our own + * error handling so just provide an entry point and store where the + * error occurred in the input stream. + */ +/* ARGSUSED */ +void +yyerror (char *s) +{ + extern char *ip_cmdblk; + + if (cldebug) + eprintf ("yyerror: %s, ip_cmdblk=%d %s\n", s, ip_cmdblk, ip_cmdblk); + err_cmdblk = ip_cmdblk; +} + + +/* Used by the . command: repeat whatever was last compiled. + * All we need to do is advance the pc up to what it would be if the + * command were typed in again. See grammar.y '.' rule. + */ +void +rerun (void) +{ + register struct codeentry *cp; + + do { + cp = coderef (pc); + pc += cp->c_length; + } while (cp->c_opcode != END); +} + + +/* CRACKIDENT -- Check given string s against keyword, set yylval, and return + * token. Used from grammar when see an identifier or from "?" and "??" lex + * rules. Make these look like identifiers for the special help commands. + * A few that need more complicated processing are checked separately. + * This is much more core efficient than putting the keywords in the + * lex spec and also makes the grammer very stable. + * TODO: sort keyword list and do binary search if things get slow. + * (better yet use a hashed symbol table - this list is getting huge) + */ +int +crackident (char *s) +{ + struct keywords { + char *k_name; /* the keyword string itself. */ + short k_token; /* yacc %token for the keyword */ + short k_yylval; /* the value associated with token.*/ + }; + + static struct keywords kw[] = { + + /* Control flow keywords. + */ + { "while", Y_WHILE, 0}, { "if", Y_IF, 0}, + { "else", Y_ELSE, 0}, { "switch", Y_SWITCH, 0}, + { "case", Y_CASE, 0}, { "default", Y_DEFAULT, 0}, + { "break", Y_BREAK, 0}, { "next", Y_NEXT, 0}, + { "return", Y_RETURN, 0}, { "goto", Y_GOTO, 0}, + { "for", Y_FOR, 0}, { "procedure", Y_PROCEDURE, 0}, + { "begin", Y_BEGIN, 0}, { "end", Y_END, 0}, + + /* Parameter and variable types. + */ + { "int", Y_INT, 0}, { "char", Y_STRING, 0}, + { "real", Y_REAL, 0}, { "string", Y_STRING, 0}, + { "file", Y_FILE, 0}, { "gcur", Y_GCUR, 0}, + { "imcur", Y_IMCUR, 0}, { "ukey", Y_UKEY, 0}, + { "pset", Y_PSET, 0}, { "bool", Y_BOOL, 0}, + { "struct", Y_STRUCT, 0}, + + /* debugging commands. + */ + { "d_d", D_D, 0}, + { "d_peek", D_PEEK, 0}, + + /* sentinel; leave it here... */ + { "", 0, 0} + }; + + static struct keywords kf[] = { + /* Keywords of intrinsic functions that get built into + * the grammar. Most intrinsics handled by intrinsic(). + */ + { "scan", Y_SCAN, 0}, + { "scanf", Y_SCANF, 0}, + { "fscan", Y_FSCAN, 0}, + { "fscanf", Y_FSCANF, 0}, + + /* sentinel; leave it here... */ + { "", 0, 0} + }; + + register struct keywords *kp; + XINT oldtopd; + static char sch, kch; /* static storage is faster here */ + char *scopy; /* non-makelower'd copy */ + + oldtopd = topd; /* save topd */ + scopy = comdstr(s); /* make a copy in the dictionary */ + makelower (scopy); /* make it lower case for compares */ + topd = oldtopd; /*restore topd but scopy still there!*/ + + /* Put the first character of the identifier we are searching for + * in local storage to permit fast rejection of keywords without all + * the overhead involved in a call to strcmp. This is an easy way + * to speed things up several times w/o coding fancy data structures. + */ + sch = *scopy; + + /* Check for and handle special-case keywords first. + */ + if (sch == *truestr && !strcmp (scopy, truestr)) { + yylval = addconst (truestr, OT_BOOL); + return (Y_CONSTANT); + } else if (sch == *falsestr && !strcmp (scopy, falsestr)) { + yylval = addconst (falsestr, OT_BOOL); + return (Y_CONSTANT); + } else if (sch == *indeflc && !strcmp (scopy, indeflc)) { + yylval = addconst (scopy, OT_INT); + return (Y_CONSTANT); + } else if (sch == *epsilonstr && !strcmp (scopy, epsilonstr)) { + char sb[REALWIDTH]; + sprintf (sb, "%e", EPSILON); + yylval = addconst (sb, OT_REAL); + return (Y_CONSTANT); + } else if (sch == *eoflc && !strcmp (scopy, eoflc)) { + yylval = addconst (CL_EOFSTR, OT_INT); + return (Y_CONSTANT); + } else if (sch == *errorstr && !strcmp (scopy, errorstr)) { + yylval = addconst (errorstr, OT_STRING); + return (Y_IDENT); + + } else if (!inarglist && parenlevel == 0) { + /* Search the keyword list; kewords are not recognized in argument + * lists and expressions, else unquoted strings like "for" and + * "file" will cause syntax errors. + */ + for (kp=kw; (kch = *kp->k_name); kp++) + if (kch == sch) + if (strcmp (scopy, kp->k_name) == 0) { + yylval = kp->k_yylval; + return (kp->k_token); + } + + } else { + /* Search the list of intrinsic functions. + */ + for (kp=kf; (kch = *kp->k_name); kp++) + if (kch == sch) + if (strcmp (scopy, kp->k_name) == 0) { + yylval = kp->k_yylval; + return (kp->k_token); + } + } + + /* S not a keyword, so it's just an identifier. + */ + yylval = addconst (s, OT_STRING); /* use original */ + return (Y_IDENT); +} + + +/* ADDCONST -- Called during parsing to convert string s into operand of + * type t and push it as an operand onto the dictionary (NOT the operand + * stack). + * Use dictionary because this routine is called at compile time and the + * operand stack is being filled with compiled code; use dictionary as + * a quiet workspace. + * Convert as per makeop(). + * Return dictionary index of new operand entry so that it may be used as + * ((struct operand *)&dictionary[$1])->o_... in yacc specs. + */ +XINT +addconst (s, t) +char *s; +int t; +{ + register struct operand *op; + XINT lasttopd; + + lasttopd = topd; /* could just derefenece op */ + op = (struct operand *) memneed (OPSIZ); + + if (t == OT_STRING) { + /* makeop with an OT_STRING type will reuse the + * string pointer but we want to compile into the dictionary. + * fortunately, it's easy because lex has already removed any + * surrounding quotes. + */ + op->o_type = t; + op->o_val.v_s = comdstr (s); + } else + *op = makeop (s, t); + + return (lasttopd); +} + + +/* LISTPARAMS -- Go through the given pfile and list out its parameters on + * t_stdout. Give all non-hidden ones first, then all hidden ones in + * parentheses. + */ +void +listparams ( + struct pfile *pfp +) +{ + register struct param *pp; + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) + if (!(pp->p_mode & M_HIDDEN)) + pretty_param (pp, currentask->t_stdout); + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) + if (pp->p_mode & M_HIDDEN) + pretty_param (pp, currentask->t_stdout); +} + + +/* PRETTY_PARAM -- Pretty print the name, value, and prompt string of + * a parameter on the output file. Put parens around the name=value string + * if a hidden parameter. + */ +void +pretty_param ( + struct param *pp, + FILE *fp +) +{ + register char ch, *p; + char buf[SZ_LINE]; + int nchars, maxch; + + /* Get terminal dimensions from the environment. + */ + maxch = c_envgeti ("ttyncols") - 1; + + p = buf; /* name = */ + if (pp->p_mode & M_HIDDEN) + *p++ = '('; + sprintf (p, "%0.12s = ", pp->p_name); + nchars = strlen (buf); + while (nchars < 16) { + fputc (' ', fp); + nchars++; + } + fputs (buf, fp); + + /* For arrays print the index list. + */ + if (pp->p_type & PT_ARRAY) { + int dim, d, amin, amax; + short *len, *off; + char ibuf[15]; /* Maximum length of an index range should + * be 13 e.g. -DDDDD:-DDDDD, plus one for the + * terminator, and one for good luck. + */ + buf[0]= '['; + buf[1] = '\0'; + + dim = pp->p_val.v_a->a_dim; + len = &(pp->p_val.v_a->a_len); + off = &(pp->p_val.v_a->a_off); + + for (d=0; d SZ_LINE-14) + break; + } + strcat (buf, "]"); + fputs (buf, fp); + nchars += strlen (buf); + + } else if (!(pp->p_valo.o_type & OT_UNDEF)) { + /* For scalars print the value if available. + */ + sprop (buf, &pp->p_valo); + if ((pp->p_type & OT_BASIC) == OT_STRING && *buf != PF_INDIRECT) { + fputc ('"', fp); + nchars++; + } + fputs (buf, fp); + nchars += strlen (buf); + if ((pp->p_type & OT_BASIC) == OT_STRING && *buf != PF_INDIRECT) { + fputc ('"', fp); + nchars++; + } + } + + if (pp->p_mode & M_HIDDEN) { + fputc (')', fp); + nchars++; + } + fputc (' ', fp); + nchars++; + + /* Advance to next field. */ + while (nchars < 32) { + fputc (' ', fp); + nchars++; + } + /* prompt */ + for (p=pp->p_prompt; (ch = *p++) != '\0' && nchars < maxch; nchars++) + switch (ch) { + case '\t': + fputs ("\\t", fp); + nchars++; + break; + case '\n': + fputs ("\\n", fp); + nchars++; + break; + case '\r': + fputs ("\\r", fp); + nchars++; + break; + case '\f': + fputs ("\\f", fp); + nchars++; + break; + default: + fputc (ch, fp); + } + fputc ('\n', fp); +} + + +/* DUMPPARAMS -- Go through the given pfile and list out its parameters on + * t_stdout in the form `task.param=value'. + */ +void +dumpparams ( + struct pfile *pfp +) +{ + register struct param *pp; + register FILE *fp = currentask->t_stdout; + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) + if (!(pp->p_mode & M_HIDDEN)) + show_param (pfp->pf_ltp, pp, fp); + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) + if (pp->p_mode & M_HIDDEN) + show_param (pfp->pf_ltp, pp, fp); + + fputs ("# EOF\n", fp); +} + + +/* SHOW_PARAM -- Print the name and value of a parameter on the output file + * in the format `task.param = value'. + */ +void +show_param ( + struct ltask *ltp, + struct param *pp, + FILE *fp +) +{ + char buf[SZ_LINE+1]; + int isstr; + + if (ltp) + fprintf (fp, "%s.%s", ltp->lt_lname, pp->p_name); + else + fputs (pp->p_name, fp); + + fputs (" = ", fp); + + if (!(pp->p_valo.o_type & OT_UNDEF)) { + sprop (buf, &pp->p_valo); + isstr = ((pp->p_type & OT_BASIC) == OT_STRING && + *buf != PF_INDIRECT); + if (isstr) + fputc ('"', fp); + fputs (buf, fp); + if (isstr) + fputc ('"', fp); + } + + fputc ('\n', fp); +} + + +/* LISTHELP -- List all the (visible) ltasks in the given package in the form + * of a sorted table. Used to give menus in response to ? and ?? directives. + */ +void +listhelp ( + struct package *pkp, + int show_invis +) +{ + static int first_col=7, maxch=20, ncol=0; + register struct ltask *ltp; + register char *ip, *op; + + char buf[4096], *list[MAXMENU]; + int nltask, last_col; + FILE *fp; + + nltask = 0; + last_col = c_envgeti ("ttyncols") - 1; + + fp = currentask->t_stdout; + op = buf; + + for (ltp = pkp->pk_ltp; ltp != NULL; ltp = ltp->lt_nlt) { + if (ltp->lt_flags & LT_INVIS && show_invis == NO) + continue; + if (nltask >= MAXMENU) + cl_error (E_UERR, "too many ltasks in menu"); + + /* Get task name. */ + list[nltask++] = op; + for (ip=ltp->lt_lname; (*op = *ip++); op++) + ; + + /* If special task, add character defining task type. */ + if (showtype()) { + if (ltp->lt_flags & LT_DEFPCK) + *op++ = '.'; + else if (ltp->lt_flags & LT_PSET) + *op++ = '@'; + } + + *op++ = EOS; + } + + /* Sort the list and output the table. */ + if (nltask) { + strsort (list, nltask); + strtable (fp, list, nltask, first_col, last_col, maxch, ncol); + } +} + + +/* LISTALLHELP -- Starting at curpack, list out all packages and their tasks + * in a circular fashion until get back to curpack. this is like the search + * path works. Label the current package in some way. Serves ?? directive. + * TODO: this should be optimized once a nice form is settled on. + */ +void +listallhelp ( + int show_invis +) +{ + register struct package *pkp; + + pkp = curpack; + do { + oprintf (" %s:\n", pkp->pk_name); + listhelp (pkp, show_invis); + if ((pkp = pkp->pk_npk) == NULL) + pkp = reference (package, pachead); + } until (pkp == curpack); +} + + +/* Break a param spec of the form [[pack.]task.]param[.field] into its + * component parts. Full is a pointer to the full name. The others are the + * addresses of char pointers in the calling routine that are to be set to + * point to the starting address, within full, of their respective components. + * All dots are set to \0 and serve as eos's for each component. + * If any of the parts are absent, the respective pointer is made to point at + * the trailing null of full. + * The last part, field, is handled by fieldcvt(). it overwrites the first + * char of the field component with the proper FN_XXX character; it is not + * made into a string by adding an additional \0. + * Call error() and do not return if something goes wrong. + * Also used to break apart the components of full task names, [pack.]task. In + * this case, the task name will be found at p and the package name at t. + * Fair enough; just keep them straight when calling. + * Modified 3/26/84 by TAM to use a static buffer, rather than mutilating + * the input string. This caused problems when programs looped and + * executed the same PUSHPARAM (or similar) more than once, e.g. + * while (i<10) {= task.param; i += 1; }. + * This bug is particularly manifest when accessing arrays in specified tasks, + * e.g. = task.array[*] + */ +void +breakout ( + char *full, + char **pk, + char **t, + char **p, + char **f +) +{ + register char *cp; + register int npts, n; + char *pts[3]; + static char buffer[SZ_LINE+1]; + + strncpy (buffer, full, SZ_LINE); + buffer[SZ_LINE] = '\0'; + + for (npts=0, cp=buffer; *cp; cp++) + if (*cp == '.') { + if (*(cp+1) == EOS) { + *cp = EOS; /* chop dot if last character */ + break; + } else { + if (npts > 3) + cl_error (E_UERR, "too many dots in param name `%s'", + full); + pts[npts++] = cp; + } + } + + for (n=0; n < npts; n++) + *(pts[n]++) = '\0'; /* null over and skip dots */ + + switch (npts) { + case 0: /* just a simple param name without dots */ + *p = buffer; + *pk = *t = *f = cp; + break; + + case 1: /* p.f or t.p depending on f */ + if (fieldcvt (pts[0])) { + /* p.f */ + *pk = *t = cp; *p = buffer; *f = pts[0]; + } else { + /* t.p */ + *pk = *f = cp; *t = buffer; *p = pts[0]; + } + break; + + case 2: /* t.p.f or pk.t.p depending on f */ + if (fieldcvt (pts[1])) { + /* t.p.f */ + *pk = cp; *t = buffer; *p = pts[0]; *f = pts[1]; + } else { + /* pk.t.p */ + *pk = buffer; *t = pts[0]; *p = pts[1]; *f = cp; + } + break; + + case 3: /* full spec */ + *pk = buffer; *t = pts[0]; *p = pts[1]; *f = pts[2]; + fieldcvt (*f); + break; + } +} + + +/* If f is a valid parameter field spec, such as p_val, then overwrite *f + * with the proper FN_XXX character and return YES, else return NO. + * Let the p_value field also be called p_filename, p_length and p_default. + * Call error() if f starts with p_ but is not found or if ambiguous + * (and abbrevs are enabled). + */ +int +fieldcvt ( + register char *f +) +{ + /* Field name and corresponding code tables. + */ + static char *fntbl[] = { + "p_name", "p_type", "p_mode", "p_value", "p_minimum", + "p_maximum", "p_prompt", "p_filename", "p_length", "p_default", + "p_xtype", NULL + }; + static char fctbl[] = { + FN_NAME, FN_TYPE, FN_MODE, FN_VALUE, FN_MIN, + FN_MAX, FN_PROMPT, FN_VALUE, FN_LENGTH, FN_VALUE, + FN_XTYPE, NULL + }; + + int kentry; + + /* Do a quick screening first. returning NO just means that f does + * not even look like a field name. + */ + if (strncmp (f, "p_", 2)) + return (NO); + + kentry = keyword (fntbl, f); + if (kentry == KWBAD) + cl_error (E_UERR, "bad param field `%s'", f); + else if (kentry == KWAMBIG) + cl_error (E_UERR, "ambiguous param field `%s'", f); + + *f = fctbl[kentry]; + return (YES); +} + + +/* Search though string table, tbl, for string s. last pointer in table + * should be NULL, ie, tbl[last] == NULL (not *tbl[last] == '\0'). + * Settle for an abbreviation if they are enabled. Return KWBAD if s + * simply not in tbl at all, KWAMBIG if abbreviations are enabled and more + * than one entry in tbl would match s, else the ordinal (index) into tbl + * at which s matched. + */ +int +keyword ( + register char *tbl[], + register char *s +) +{ + register int i; + register char *kentry; + int cand, len; + + i = 0; + cand = KWBAD; + len = strlen (s); + + if (abbrev()) { + for (kentry = tbl[0]; kentry; kentry = tbl[++i]) + if (!strncmp (s, kentry, len)) { + if (kentry[len] == '\0') + return (i); /* exact hit */ + if (cand == KWBAD) + cand = i; + else + cand = KWAMBIG; /* might still hit exact */ + } + + } else for (kentry = tbl[0]; kentry; kentry = tbl[++i]) + if (!strcmp (s, kentry)) + return (i); + + return (cand); +} + + +/* Given a, possibly abbreviated, function name to run, look it up and + * run it if found. it gets nargs arguments from the operand stack. + */ +void +intrfunc ( + char *fname, + int nargs +) +{ + static char *ifnames[] = { + "abs", "access", "atan2", "cos", + "defpac", "defpar", "deftask", "envget", + "exp", "frac", "int", "log", + "log10", "nscan", "max", "min", + "mod", "nint", "osfn", "radix", + "real", "sin", "sqrt", "str", + "substr", "tan", "mktemp", "stridx", + "strlen", "imaccess", "defvar", "strldx", + "strstr", "strlwr", "strupr", "isindef", + "strlstr", + NULL + }; + static int optbl[] = { + UNOP|OP_ABS, UNOP|OP_ACCESS, BINOP|OP_ATAN2, UNOP|OP_COS, + UNOP|OP_DEFPAC, UNOP|OP_DEFPAR, UNOP|OP_DEFTASK, UNOP|OP_ENVGET, + UNOP|OP_EXP, UNOP|OP_FRAC, UNOP|OP_INT, UNOP|OP_LOG, + UNOP|OP_LOG10, MULTOP|OP_NSCAN, MULTOP|OP_MAX, MULTOP|OP_MIN, + BINOP|OP_MOD, UNOP|OP_NINT, UNOP|OP_OSFN, BINOP|OP_RADIX, + UNOP|OP_REAL, UNOP|OP_SIN, UNOP|OP_SQRT, UNOP|OP_STR, + MULTOP|OP_SUBSTR, UNOP|OP_TAN, UNOP|OP_MKTEMP, BINOP|OP_STRIDX, + UNOP|OP_STRLEN, UNOP|OP_IMACCESS, UNOP|OP_DEFVAR, BINOP|OP_STRLDX, + BINOP|OP_STRSTR, UNOP|OP_STRLWR, UNOP|OP_STRUPR, UNOP|OP_ISINDEF, + BINOP|OP_STRLSTR, + }; + int index, op; + int i, n, subi[2]; + char sbuf[SZ_LINE+1]; + struct operand o; + + index = keyword (ifnames, fname); + if (index == KWBAD) + cl_error (E_UERR, "unknown function `%s'", fname); + if (index == KWAMBIG) + cl_error (E_UERR, "ambiguous function `%s'", fname); + + op = optbl[index]; + + /* if do this by shifting the cases and op to the right OP_BITS, this + * will compile as a jump table. not worth it until it gets larger. + */ + switch (op & ~OP_MASK) { + case UNOP: + if (nargs != 1) + cl_error (E_UERR, e_onearg, ifnames[index]); + unop (op & OP_MASK); + break; + + case BINOP: + if (nargs != 2) + cl_error (E_UERR, e_twoargs, ifnames[index]); + binop (op & OP_MASK); + break; + + case MULTOP: + /* right now, this is just for min, max, nscan, and substr. + * this will have to be smarted up if add other functions. + */ + + switch (op & OP_MASK) { + case OP_NSCAN: + if (nargs > 0) + cl_error (E_UERR, "nscan has no arguments"); + o.o_type = OT_INT; + o.o_val.v_i = get_nscanval(); + pushop (&o); + break; + + case OP_MAX: + case OP_MIN: + if (nargs <= 0) + cl_error (E_UERR, e_geonearg, ifnames[index]); + /* just leave top op if its the only one. + */ + if (nargs > 1) { + op &= OP_MASK; /* avoid masking for every loop */ + while (--nargs) + binop (op); + } + break; + + case OP_SUBSTR: + if (nargs != 3) + cl_error (E_UERR, "substr requires 3 arguments"); + + for (n=1; n >= 0; n--) { /* get indices */ + opcast (OT_INT); + o = popop(); + subi[n] = o.o_val.v_i; + } + + opcast (OT_STRING); /* get string arg */ + o = popop(); + + if (subi[1] >= subi[0]) { + n = subi[1] - subi[0] + 1; + strncpy (sbuf, &o.o_val.v_s[subi[0]-1], n); + } else { + /* Reverse the string. */ + n = subi[0] - subi[1] + 1; + for (i = 0; i < n; i++) + sbuf[i] = o.o_val.v_s[subi[0]-i-1]; + } + sbuf[n] = '\0'; + + o.o_val.v_s = sbuf; + pushop (&o); + break; + + default: + goto err; + } + break; + + default: +err: cl_error (E_IERR, e_badsw, op, "intrfunc()"); + } +} + + +/* Convert string s to sexagesimal operand, of type OT_REAL. Set opundef() + * if conversion is bad somehow. Allow both h:m and h:m:s forms. + */ +struct operand +sexa (char *s) +{ + struct operand o; + int n, sign; + int hr, minutes; + float sec; + extern double atof(); + + o.o_type = OT_REAL; + sign = (*s == '-') ? (s++, -1) : 1; + + minutes = 0; + sec = 0.; + n = sscanf (s, "%d:%d:%hf", &hr, &minutes, &sec); + if (n < 1 || minutes < 0 || sec < 0) + setopundef (&o); + else + o.o_val.v_r = sign * (atof (s)); + /* Old evaluation producing roundoff errors. + o.o_val.v_r = sign*(hr + ((float)minutes)/60. + sec/3600.); + */ + + return (o); +} + +/* Convert a sexagesimal real back to an index range. + */ +void +sexa_to_index ( + double r, + int *i1, + int *i2 +) +{ + int sgn; + + if (r < 0) { + sgn = -1; + r = -r; + } else + sgn = 1; + + *i1 = (int) r; /* add a little for round-off*/ + *i2 = (int) (60.0e0 * (r - *i1) + .001); + *i1 = sgn * *i1; +} + + +/* ADDPIPE -- Generate a new pipe file name and push it onto the pipe stack. + * The strategy is to generate a unique pipefile name of the form "pipeXXX", + * where XXX is an integer of 5 digits or less which is what is saved on the + * pipe stack. Return a pointer to the name of the new pipefile. + */ +char * +addpipe (void) +{ + static int pipecode = 0; + char *pipefile(); + + if (pipecode == 0) + pipecode = c_getpid(); + + /* Get unique pipefile name described by a simple integer. + */ + do { + /* + * There seems to be a problem with this code in the VMS compiler. + * It has been changed to a form which will work for UNIX and VMS. + * + * pipecode = (pipecode++ % MAX_PIPECODE); + * + */ + pipecode %= MAX_PIPECODE; + + /* There can be applications where multiple CL are spawned in + * relatively short order so that the PIDs are close. Incrementing + * the least significant digits can result in duplications. So + * instead we use the lower digits as the "unique" part and + * increment the higer digits. + * + * pipecode++; + */ + pipecode += 1000; + + } while (c_access (pipefile(pipecode),0,0) == YES); + + pipetable[nextpipe++] = pipecode; + if (nextpipe >= MAXPIPES) + cl_error (E_UERR, "Too many pipes"); + + return (pipefile (pipecode)); +} + + +/* GETPIPE -- Get the name of the last pipefile. + */ +char * +getpipe (void) +{ + char *pipefile(); + + if (nextpipe == 0) + cl_error (E_IERR, "Pipestack underflow"); + return (pipefile (pipetable[nextpipe-1])); +} + + +/* DELPIPES -- Delete N pipefiles (the actual file may not have been created + * yet), and pop N pipes off the pipe stack. If N is zero, all pipefiles are + * deleted and the pipestack is cleared (i.e., during error recovery). + */ +void +delpipes ( + register int npipes +) +{ + register int pipe; + char *pipefile(); + + if (npipes == 0) { + while (nextpipe > 0) + c_delete (pipefile (pipetable[--nextpipe])); + } else { + while (npipes-- > 0) { + if ((pipe = --nextpipe) < 0) + cl_error (E_IERR, "Pipestack underflow"); + c_delete (pipefile (pipetable[pipe])); + } + } +} + + +/* PIPEFILE -- Given the pipecode, format a pipefile name in static internal + * buffer and return pointer to pipefile name to caller. + */ +char * +pipefile ( + int pipecode +) +{ + static char fname[SZ_PIPEFILENAME+1]; + char *dir; + char *envget(); + + /* Put pipefiles in 'pipes' or 'uparm' if defined, else use tmp. Do + * not put pipe files in current directory or pipe commands will fail + * when used in someone elses directory. + */ + if (envget ("pipes") != NULL) + dir = "pipes$"; + else if (envget ("uparm") != NULL) + dir = "uparm$"; + else + dir = "tmp$"; + sprintf (fname, "%spipe%d", dir, pipecode); + + return (fname); +} + + +/* LOOPINCR -- increments the loop counter and stores the destination + * address for NEXT statements. It should be called just before the + * destination is compiled. + */ +void +loopincr (void) +{ + if (nestlevel >= MAX_LOOP) + cl_error (E_UERR, "Nesting too deeply."); + + brkdest[nestlevel] = 0; + nextdest[nestlevel] = pc; + nestlevel++; +} + + +/* LOOPDECR -- decrements the loop counter, and if the break destination + * has been set it resolves the GOTO statement which has been made + * the target of BREAK's. + */ +void +loopdecr (void) +{ + int p_goto; + + p_goto = brkdest[--nestlevel]; + if (p_goto != 0) + coderef(p_goto)->c_args = pc - p_goto - 3; +} + + +/* SETSWITCH -- creates the jumptable which will be used in the SWITCH. + * On entry to setswitch the stack contains a pointer to the SWITCH + * operand, and pointers to the first and last operands of each + * CASE and DEFAULT block, i.e. the CASE and DEFAULT operands and the + * GOTO operands which terminate each block. + * The jumptable is created at the location of the current pc. + */ +void +setswitch (void) +{ + int code, jmp, njump, assgn, oper, delta; + + /* First get the size of the jump table by reading + * backwards on the stack until we find the switch + * statement. + */ + oper = topcs; + code = coderef(stack[oper])->c_opcode; + njump = 2; + + while (code != SWITCH) { + if (code == CASE) + njump++; + else if (code != GOTO && code != DEFAULT) + cl_error (E_UERR, "Corrupt stack in SWITCH analysis."); + + oper++; + code = coderef(stack[oper])->c_opcode; + } + + assgn = stack[oper]; + + /* To create the jump table we read the control stack + * to get the addresses of each of the case statements + * and the default statement. The values associated with + * each case statement are stored in that operand. The + * addresses are popped and transferred to the jump table. + * The first location in the jump table is reserved for + * the DEFAULT statement and is 0 if this is not defined. + * We know the size of the jump table, so as we pop off + * the goto statements at the end of the CASE blocks + * we can fill in the addresses. + */ + jmp = pc + 1; + oper = pop(); + code = coderef(oper)->c_opcode; + stack[pc] = 0; + + while (code != SWITCH) { + + switch (code) { + case DEFAULT: + stack[pc] = oper-assgn; + break; + + case CASE: + stack[jmp++] = oper-assgn; + break; + + case GOTO: + delta = pc + njump - oper - 3; + coderef(oper)->c_args = delta; + break; + + default: + cl_error (E_UERR, "Corrupt stack in SWITCH analysis."); + } + + oper = pop(); + code = coderef(oper)->c_opcode; + } + + stack[jmp] = 0; /* Fill in terminator. */ + + /* Put address of jump table in ASSIGN operand. + */ + coderef(oper)->c_args = pc - oper; + pc += njump; + + /* Fill in address of GOTO following ASSIGN. + */ + oper += 3; + coderef(oper)->c_args = pc - oper - 3; +} + + +/* IN_SWITCH -- determines whether a CASE or DEFAULT block is + * legal at the current location. + */ +int +in_switch (void) +{ + int oper, code, oper2, code2, status; + + oper = pop(); + code = coderef(oper)->c_opcode; + status = 1; + + switch (code) { + case SWITCH: + push (oper); + break; + + case GOTO: + /* Previous operand must be DEFAULT or CASE. + */ + oper2 = pop(); + code2 = coderef(oper2)->c_opcode; + if (code2 != CASE && code2 != DEFAULT) + status = 0; + push (oper2); + push (oper); + break; + + default: + status = 0; + } + + return (status); +} + + +/* CASESET -- Fill in the values for which the current case block is to be + * executed. + */ +void +caseset ( + memel *parg, + int ncaseval +) +{ + struct operand *o; + static char *badcase = "Invalid case constant."; + int ival; + + for (ival = 0; ival < ncaseval; ival++) { + + o = (struct operand *) pop(); + + if (o->o_type == OT_STRING) { + /* Only chars, not full strings. + */ + if (*o->o_val.v_s == 0) + cl_error (E_UERR, badcase); + if (*(o->o_val.v_s + 1) != 0) + cl_error (E_UERR, badcase); + + *parg++ = (int) *o->o_val.v_s; + + } else if (o->o_type == OT_INT) { + *parg++ = o->o_val.v_i; + + } else + cl_error (E_UERR, badcase); + } +} + + +/* SETLABEL -- called when a label is first seen. It allocates + * space for the label on the dictionary and also copies the + * label name onto the dictionary. The label is placed at the + * top of a linked list. + */ +struct label * +setlabel ( + struct operand *name +) +{ + struct label *p; + + p = (struct label *) memneed (sizeof(struct label)); + p->l_name = comdstr (name->o_val.v_s); + + if (label1 == NULL) + p->l_next = NULL; + else + p->l_next = label1; + + label1 = p; + return (p); +} + + +/* GETLABEL -- returns the label struct corresponding to the string + * name, or NULL if the label has not been defined. + */ +struct label * +getlabel ( + struct operand *name +) +{ + struct label *l; + + l = label1; + while (l != NULL) { + if (!strcmp (name->o_val.v_s, l->l_name)) + return (l); + l = l->l_next; + } + + return (NULL); +} + + +/* SETIGOTO -- maintains the list of indirect goto's. + * Note that an indirect GOTO is identical in format to a + * normal GOTO. The argument, instead of pointing to the destination + * is used as the list pointer. When the destination is defined, + * the GOTO is taken out of the indirect list. + */ +void +setigoto ( + int loc +) +{ + if (igoto1 < 0) + coderef(loc)->c_args = -1; + else + coderef(loc)->c_args = igoto1; + + igoto1 = loc; +} + + +/* UNSETIGOTO -- takes a GOTO out of the indirect list so that + * the target may be put in the argument. + */ +void +unsetigoto ( + int loc +) +{ + int last, curr; + + last = NULL; + curr = igoto1; + + while (curr != loc) { + last = curr; + curr = coderef(curr)->c_args; + } + + if (last == NULL) + igoto1 = coderef(curr)->c_args; + else + coderef(last)->c_args = coderef(curr)->c_args; +} + + +/* MAKE_IMLOOP -- compiles the meta-code for the indexing of arrays in + * implicit array loops e.g. a[*,5]. + */ +int +make_imloop ( + int i1, + int i2 +) +{ + int mode; + + if (n_oarr) { + /* Array limits already defined, check for agreement. + */ + if (i1 != oarr_beg[i_oarr] || i2 != oarr_end[i_oarr]) + cl_error (E_UERR, "Inconsistent open refs.\n"); + mode = -1; + } else { + oarr_beg[i_oarr] = i1; + oarr_end[i_oarr] = i2; + if (i_oarr) + mode = -1; + else + /* This is the PUSHINDEX which will + * initialize the loop variables. + */ + mode = 0; + } + i_oarr++; + + return (mode); +} + + +/* Y_TYPEDEF -- Convert a type specifier keyword into a datatype code. + */ +int +y_typedef (char *key) +{ + if (strcmp (key, "string") == 0 || strcmp (key, "char") == 0) + return (V_STRING); + else if (strcmp (key, "int") == 0) + return (V_INT); + else if (strcmp (key, "real") == 0) + return (V_REAL); + else if (strcmp (key, "bool") == 0) + return (V_BOOL); + else if (strcmp (key, "file") == 0) + return (V_FILE); + else if (strcmp (key, "gcur") == 0) + return (V_GCUR); + else if (strcmp (key, "imcur") == 0) + return (V_IMCUR); + else if (strcmp (key, "ukey") == 0) + return (V_UKEY); + else if (strcmp (key, "pset") == 0) + return (V_PSET); + else if (strcmp (key, "struct") == 0) + return (V_STRUCT); + else + cl_error (E_UERR, "illegal type specifier `%s'", key); + /*NOTREACHED*/ +} + + +/* P_POSITION -- Called when we get a syntax error in the parser. Print + * the current cmdblk and point to the offending token. + */ +void +p_position (void) +{ + register int i; + + eprintf ("**: %s ", cmdblk); /* '\n' in cmdblk */ + + for (i=0; i < err_cmdblk-cmdblk; i++) + eprintf ("%c", ((cmdblk[i] == '\t') ? '\t' : ' ') ); + + eprintf ("^\n"); +} diff --git a/pkg/cl/grammar.h b/pkg/cl/grammar.h new file mode 100644 index 00000000..21d15e08 --- /dev/null +++ b/pkg/cl/grammar.h @@ -0,0 +1,61 @@ +/* + * GRAMMAR.H -- Include stuff for parser and other grammar-related routines. + */ + +/* fieldcvt() takes the p_xxx parameter field spec and replaces it with + * one of these field_name letters. this makes testing and using fields much + * faster for paramget(), paramset(), etc. + * the letter is the first letter of the field, or the second if ambiguous. + * FN_NULL is to test when field came back from fieldcvt() unspecified. + * or when calling paramset() or paramget() and you want the "worth" field. + * The aliases for p_value all use FN_VALUE. see fieldcvt() in gram.c. + */ + +#define FN_NAME 'N' +#define FN_TYPE 'T' +#define FN_MODE 'O' +#define FN_VALUE 'V' +#define FN_LENGTH 'L' +#define FN_MIN 'I' +#define FN_MAX 'A' +#define FN_PROMPT 'P' +#define FN_XTYPE 'X' /* Extended type (list, gcur, etc) */ +#define FN_NULL '\0' + +/* possible return values from keyword(), in gram.c. + */ +#define KWBAD (-1) /* keyword not found */ +#define KWAMBIG (-2) /* keyword ambiguous */ + +/* magic constants. + */ +#define CL_EOF (-2) /* integer value of EOF in language */ +#define CL_EOFSTR "-2" /* string equivalent of the above */ +#define PBRACE 1000 /* start brace level in procedure */ + +#define NOLOG 0 /* do not save command block in logfile */ +#define LOG 1 /* save command block in logfile */ + +/* Constants determining how the parser is being called. */ +#define PARSE_PARAMS 0 /* Parsing parameters at beginning. */ +#define PARSE_BODY 1 /* Parsing body of script. */ +#define PARSE_FREE 2 /* Not a procedure script. */ + +/* Command/compute mode status package. The lexical mode may be set + * explicitly for a particular command input stream. While in command + * mode (the default), the sequence #{ at the beginning of a line causes + * compute mode to be permanently set for that stream (e.g., in a comment + * at the head of a script file). We use an otherwise unused bit in the + * stdio file descriptor flag word to record whether or not compute mode + * is set on a stream. + */ +#define _LEXBIT 0100000 +#define lex_setcpumode(fp) ((fp)->_fflags |= _LEXBIT) +#define lex_clrcpumode(fp) ((fp)->_fflags &= ~_LEXBIT) +#define lex_cpumodeset(fp) ((fp)->_fflags & _LEXBIT) + +extern int parse_state; /* What are we parsing? */ +extern int proc_script; /* In a procedure script? */ +extern struct pfile *parse_pfile; /* Where parsed params are added. */ + +char *today(); /* returns pointer to todays date */ diff --git a/pkg/cl/grammar.l b/pkg/cl/grammar.l new file mode 100644 index 00000000..7a5f6adf --- /dev/null +++ b/pkg/cl/grammar.l @@ -0,0 +1,198 @@ +comment "#" + +D [0-9] +H [0-9a-fA-F] +A [a-zA-Z] + +%% + +[ \t]+ /* groups of blanks and tabs, while significant as delimiters, + * are otherwise ignored. + */ ; + +","[ \t]*\n { /* trailing ',' implies continuation */ + return (','); + } + +"\\"[ \t]*\n { /* trailing '\' completely absorbed */ + } +^[ \t]*"!".* { + /* Host os command escape. Remove everything up through + * '!'. Let clsystem decide what to do with null cmd. + * Must precede the "!" YOP_NOT spec in this file. + */ + register char *cp; + for (cp = yytext; *cp++ != '!'; ) + ; + yylval = addconst (cp, OT_STRING); + return (Y_OSESC); + } + + +"|&" return (Y_ALLPIPE); /* pipe all, even stderr */ +">>" return (Y_APPEND); /* append all but stderr */ +">>&" return (Y_ALLAPPEND); /* append all, even stderr */ +">&" return (Y_ALLREDIR); /* redirect all, even stderr */ +(">"|">>")("G"|"I"|"P")+ { + yylval = addconst (yytext, OT_STRING); + return (Y_GSREDIR); + } + +"<=" return (YOP_LE); /* operators... */ +">=" return (YOP_GE); +"==" return (YOP_EQ); +"!=" return (YOP_NE); +"**" return (YOP_POW); +"||" return (YOP_OR); +"&&" return (YOP_AND); +"!" return (YOP_NOT); +"+=" return (YOP_AOADD); +"-=" return (YOP_AOSUB); +"*=" return (YOP_AOMUL); +"/=" return (YOP_AODIV); +"//=" return (YOP_AOCAT); +"//" return (YOP_CONCAT); + +"}" { if (dobrace) { + dobrace = NO; + return (*yytext); + } else { + dobrace = YES; + unput (*yytext); + return (';'); + } + } + + +"^" return (*yytext); /* debug: print stack */ +"/" return (*yytext); /* debug: single step */ + +"?" return (crackident (yytext)); /* current package help */ +"??" return (crackident (yytext)); /* all tasks help */ + +"&" { extern bracelevel; + if (bracelevel) { + eprintf ("ERROR: background not allowed within statement block\n"); + return ('#'); + } else { + yyleng = 0; + while ((yytext[yyleng]=input()) != '\n') + yyleng++; + yytext[yyleng] = '\0'; + bkg_init (yytext); + return (Y_NEWLINE); + } + } + +({A}|"$"|"_")({A}|"$"|{D}|"_"|".")* { + /* crackident() sets yylval and returns token value. + */ + return (crackident (yytext)); + } + +{D}+(([bB])|({H}*[xX]))? { + /* must precede OT_REAL as integers also match there */ + yylval = addconst (yytext, OT_INT); + return (Y_CONSTANT); + } +(({D}+)|(({D}*"."{D}+)|({D}+"."{D}*)))([eEdD][+-]?{D}+)? { + yylval = addconst (yytext, OT_REAL); + return (Y_CONSTANT); + } + +{D}+":"{D}+(":"{D}*("."{D}*)?)? { + /* sexagesimal format */ + yylval = addconst (yytext, OT_REAL); + return (Y_CONSTANT); + } + +(\")|(\') { /* Quoted string. call traverse() to read the + * string into yytext. + */ + traverse (*yytext); + yylval = addconst (yytext, OT_STRING); + return (Y_CONSTANT); + } + +\n return (Y_NEWLINE); + +{comment} { /* Ignore a comment. */ + while (input() != '\n') + ; + unput ('\n'); + } + +. return (*yytext); + +%% + +#include "errs.h" + +/* See gram.c for the various support functions, such as addconst() + * and crackident(). Traverse is included here since it directly + * references input, unput, yytext, etc. + */ + +/* TRAVERSE -- Called by the lexical analyzer when a quoted string has + * been recognized. Characters are input and deposited in yytext (the + * lexical analyzer token buffer) until the trailing quote is seen. + * Strings may not span lines unless the newline is delimited. The + * recognized escape sequences are converted upon input; all others are + * left alone, presumably to later be converted by other code. + * Quotes may be included in the string by escaping them, or by means of + * the double quote convention. + */ +traverse (delim) +char delim; +{ + register char *op, *cp, ch; + static char *esc_ch = "ntfr\\\"'"; + static char *esc_val = "\n\t\f\r\\\"\'"; + char *index(); + + for (op=yytext; (*op = input()) != EOF; op++) { + if (*op == delim) { + if ((*op = input()) == EOF) + break; + if (*op == delim) + continue; /* double quote convention; keep one */ + else { + unput (*op); + break; /* normal exit */ + } + + } else if (*op == '\n') { /* error recovery exit */ + *op = '\0'; + cl_error (E_UERR, "Newline while processing string"); + break; + + } else if (*op == '\\') { + if ((*op = input()) == EOF) { + break; + } else if (*op == '\n') { + --op; /* explicit continuation */ + while ((ch = input()) && isspace(ch) || ch == '#') { + if (ch == '#') + while ((ch = input()) && ch != '\n') + ; + } + unput (ch); + continue; + } else if ((cp = index (esc_ch, *op)) != NULL) { + *op = esc_val[cp-esc_ch]; + } else if (isdigit (*op)) { /* '\0DD' octal constant */ + *op -= '0'; + while (isdigit (ch = input())) + *op = (*op * 8) + (ch - '0'); + unput (ch); + } else { + ch = *op; /* unknown escape sequence, */ + *op++ = '\\'; /* leave it alone. */ + *op = ch; + } + } + } + + *op = '\0'; + yyleng = (op - yytext); +} diff --git a/pkg/cl/grammar.y b/pkg/cl/grammar.y new file mode 100644 index 00000000..b90d0564 --- /dev/null +++ b/pkg/cl/grammar.y @@ -0,0 +1,2020 @@ +%{ + +#define import_spp +#define import_libc +#define import_stdio +#define import_ctype +#include + +#include "config.h" +#include "mem.h" +#include "operand.h" +#include "param.h" +#include "grammar.h" +#include "opcodes.h" +#include "clmodes.h" +#include "task.h" +#include "construct.h" +#include "errs.h" +#include "proto.h" + + +/* CL parser, written as a yacc grammar: + * build up an (rpn) instruction sequence begining at the base of the + * operand stack as the grammar is recognized. + * + * The parser may be called during parameter initialization (initiated by + * the CALL meta-code instruction), and to parse the executable portion + * (from the EXEC instruction). + * + * CONSTANT's are put on the dictionary by addconst() rather than the operand + * stack to avoid conflict with the code being created. They are accessed + * by using the yylval of IDENT and CONSTANT as dictionary indices that + * point to struct operands. This is facilitated with the stkop() macro. + * Make sure that topd and topcs are restored on return to discard these + * temporaries. + * When building offsets for branches, such as BIFF and GOTO, allow + * for the advancement of the pc by the size of the instruction (in ints). + * See opcodes.c for the code executed by the branch instructions. + */ + +extern int cldebug; +#define lint /* turns off sccsid in Yacc parser */ + +/* shorthand way to get at operands in dictionary. x will be values returned + * from addconst() by way of $n's from CONSTANT and IDENT tokens; see gram.c + * and its uses in grammar.l. also see pushop() for a description of the stack. + */ +#define stkop(x) (reference (operand, (x))) + +int dobkg = 0; /* set when want to do code in bkground */ +int npipes = 0; /* number of pipes in a command */ +XINT pipe_pc; /* pc of last ADDPIPE instruction */ +int posit = 0; /* positional argument count */ +int inarglist = 0; /* set when in argument list */ +int parenlevel = 0; /* level of paren nesting in command */ +int index_cnt; /* Index counter in array ref's */ +char curr_param[SZ_FNAME]; /* Parameter name of ref's */ +char curr_task[SZ_FNAME]; /* ltaskname of command */ +XINT stmt_pc; /* PC at beginning of current statement */ +int varlist; /* Declaration is list directed. */ +int vartype; /* Type of declaration. */ +int do_params; /* Are param definitions legal here? */ +int errcnt; /* Syntax error count. */ +int inited; /* Was variable already initialized. */ +struct param *pp; /* Pointer to param being compiled. */ +int n_aval; /* Number of array init values. */ +int lastref; /* Was last ref an array? */ +int for_expr; /* Was there an expression in FOR? */ +char *ifseen; /* Have we just processed an IF? */ + +/* context-sensitive switches. technique is ok, but beware of nesting! + */ +static int absmode = 0; /* set by first absolute mode arg in cmd*/ +static int newstdout = 0; /* set if stdout redirected in arg */ +static int bracelevel = 0; /* set while in s_list to inhibit & */ +static int tbrace = 0; /* fake braces for declarations */ +static int dobrace = 0; /* handling braces. */ +static int sawnl = 0; /* set when EOST was \n, else 0 */ +static int printstmt = 0; /* set when parsing FPRINT statement */ +static int scanstmt = 0; /* set when parsing SCAN statement */ + +/* printf-format error messages. + */ +char *posfirst = "All positional arguments must be first\n"; +/* char *look_parm= "Error searching for parameter `%s'."; */ +char *inval_arr= "Invalid array type for `%s'."; +char *inv_index= "Invalid index definition for `%s'."; +char *arrdeferr= "Error in array initialization for `%s'."; +/* char *arrinbrack="Array initialization must be in brackets for `%s'."; */ +char *badparm = "Parameter definition of `%s' is illegal here."; +char *illegalvar="Illegal variable declarations."; +char *locallist= "Local list variables are not permitted."; +char *twoinits = "Two initializations for parameter `%s'."; +char *exlimits = "Explicit range required for loop in external param.\n"; + +extern char cmdblk[SZ_CMDBLK+1]; /* Command buffer in history.c */ +extern char *ip_cmdblk; /* Pointer to current char in command.*/ +extern char *err_cmdblk; /* ip_cmdblk when error detected. */ + +char *index(); +struct param *initparam(); +struct label *getlabel(), *setlabel(); + +/* arbitrary large number for bracelevel in a procedure script + */ +#define MAX_ERR 10 +#define EYYERROR { err_cmdblk = ip_cmdblk; YYERROR; } + +%} + +%token Y_SCAN Y_SCANF Y_FSCAN Y_FSCANF Y_OSESC +%token Y_APPEND Y_ALLAPPEND Y_ALLREDIR Y_GSREDIR Y_ALLPIPE +%token D_D D_PEEK +%token Y_NEWLINE Y_CONSTANT Y_IDENT +%token Y_WHILE Y_IF Y_ELSE +%token Y_FOR Y_BREAK Y_NEXT +%token Y_SWITCH Y_CASE Y_DEFAULT +%token Y_RETURN Y_GOTO +%token Y_PROCEDURE Y_BEGIN Y_END +%token Y_BOOL Y_INT Y_REAL Y_STRING Y_FILE Y_STRUCT +%token Y_GCUR Y_IMCUR Y_UKEY Y_PSET + +%right '=' YOP_AOADD YOP_AOSUB YOP_AOMUL YOP_AODIV YOP_AOCAT +%left YOP_OR +%left YOP_AND +%left YOP_EQ YOP_NE +%left '<' '>' YOP_LE YOP_GE +%left YOP_CONCAT +%left '+' '-' +%left '*' '/' '%' +%left YOP_NOT UMINUS /* supplies precedence for unary minus */ +%left YOP_POW + +%start block + +%% + +block : /* empty */ { + /* Done once on entry but after at least one call to + * yylex(). Good for initing parser flags. + * Note: this does not get called in procedure scripts. + */ + if (cldebug) + eprintf ("parse init (block)...\n"); + + errcnt = 0; + err_cmdblk = 0; + dobkg = 0; + inarglist = 0; + parenlevel = 0; + bracelevel = 0; + tbrace = 0; + dobrace = 0; + do_params = YES; + last_parm = NULL; + ifseen = NULL; + label1 = NULL; + parse_pfile= currentask->t_pfp; + } + + | '.' NL { + /* Prepare to rerun whatever was compiled last. + * Does not work for the debug commands builtin here. + */ + if (parse_state != PARSE_FREE) { + eprintf ("Illegal parser state.\n"); + EYYERROR; + } + rerun(); + YYACCEPT; + } + + | block { + if (parse_state == PARSE_PARAMS) { + eprintf ("Illegal parser state.\n"); + EYYERROR; + } + } + debug xstmt { + if (sawnl && bracelevel == 0) { + if (!errcnt) + compile (END); + if (ifseen) { + /* Simulate an unput of what has been read + * from the current line. + */ + ip_cmdblk = ifseen; + } + YYACCEPT; + } + } + + | script_params { + /* Parse the parameters in a script file. This will + * normally be done on a call by pfileread(). + */ + if (parse_state != PARSE_PARAMS) { + eprintf ("Illegal parser state.\n"); + errcnt++; + } + YYACCEPT; + } + + | script_body { + /* Parse the executable statements in a script. + */ + if (parse_state != PARSE_BODY) { + eprintf ("Illegal parser state.\n"); + errcnt++; + } + if (!errcnt) + compile (END); + YYACCEPT; + } + + | error NL { + /* This catches errors that the two other error lines + * can't get, e.g. a missing `}' at the end of a script, + * or errors occuring in interactive input. + */ + yyerrok; + + /* Discard everything and compile a null statement. + */ + if (!errcnt) { + do_params = YES; + pc = currentask->t_bascode; + if (parse_state != PARSE_PARAMS) + compile (END); + + topd = currentask->t_topd; + topcs = currentask->t_topcs; + + /* Unlink any added parms. Resetting of topd will + * already have reclaimed space. + */ + if (last_parm) { + last_parm->p_np = NULL; + currentask->t_pfp->pf_lastpp = last_parm; + last_parm = NULL; + } + } + + /* Print cmdblk and show position of error. + */ + p_position(); + if (currentask->t_flags & T_SCRIPT) + cl_error (E_UERR, "syntax error, line %d", + currentask->t_scriptln); + else + cl_error (E_UERR, "syntax error"); + + YYACCEPT; + } + ; + +debug : /* empty */ + | D_XXX EOST { + /* debug are those debugging functions that + * should be run directly and not through a + * builtin task due to stack or other changes, + * ie, don't change what we are trying to show. + */ + printf ("\n"); + } debug + ; + +D_XXX : D_D { + d_d(); /* show dictionary/stack pointers */ + } + | D_PEEK Y_CONSTANT { /* show a dictionary location */ + if (stkop($2)->o_type & OT_INT) { + int idx; + idx = stkop($2)->o_val.v_i; + eprintf ("%d:\t%d (0%o)\n", idx, stack[idx], + stack[idx]); + } else + eprintf ("usage: D_PEEK \n"); + } + | '~' { + d_stack (pc, 0); /* show compiled code */ + } + ; + +script_params : proc_stmt + var_decls + begin_stmt { + /* Check for required params. + */ + if (!errcnt) + proc_params(n_procpar); + } + ; + +script_body: begin_stmt { + /* Initialize parser for procedure body. + */ + if (cldebug) + eprintf ("parse init (script_body)...\n"); +ready_(); + + errcnt = 0; + err_cmdblk = 0; + dobkg = 0; + inarglist = 0; + parenlevel = 0; + dobrace = 0; + bracelevel = PBRACE; /* disable lexmodes; force "end" */ + tbrace = 0; + do_params = NO; + last_parm = NULL; + ifseen = NULL; + label1 = NULL; + parse_pfile= currentask->t_pfp; + } + s_list + opnl + end_stmt + ; + +proc_stmt: Y_PROCEDURE { + /* Initialize parser for procedure parameters. + */ + if (cldebug) + eprintf ("parse init (proc_stmt)...\n"); + + errcnt = 0; + err_cmdblk = 0; + dobkg = 0; + inarglist = 0; + parenlevel = 0; + bracelevel = PBRACE; + tbrace = 0; + dobrace = 0; + do_params = YES; + last_parm = NULL; + label1 = NULL; + } + param bparam_list EOST + ; + +bparam_list: /* Nothing at all, not even parens. */ + { + n_procpar = 0; + } + | LP param_list RP + ; + +/* The definition of the parameter list excludes lists of the + * form a,,b + */ +param_list: /* empty */ { + n_procpar = 0; + } + | xparam_list + ; + +xparam_list: param { + n_procpar = 1; + if (!errcnt) + push (stkop($1)); + } + | xparam_list DELIM param { + n_procpar++; + if (!errcnt) + push (stkop($3)); + } + ; + +var_decls: /* No params. */ + | var_decl_block + ; + +var_decl_block: var_decl_line + | var_decl_block var_decl_line + ; + +var_decl_line: EOST /* Blank. */ + | var_decl_stmt + | error NL { + /* This catches errors in the parameter declarations + * of a procedure script. + */ + yyerrok; + + /* Discard everything and compile a null statement. + */ + if (!errcnt) { + do_params = YES; + pc = currentask->t_bascode; + if (parse_state != PARSE_PARAMS) + compile (END); + + topd = currentask->t_topd; + topcs = currentask->t_topcs; + + /* Unlink any added parms. Resetting of topd will + * already have reclaimed space. + */ + if (last_parm) { + last_parm->p_np = NULL; + currentask->t_pfp->pf_lastpp = last_parm; + last_parm = NULL; + } + } + + /* Print cmdblk and show position of error. We know + * we're parsing a procedure script, so print the line + * number too. + */ + p_position(); + cl_error (E_UERR, "syntax error, line %d", + currentask->t_scriptln); + } + ; + +var_decl_stmt: typedefs { + /* For in-line definitions we don't want + * to freeze stuff on the dictionary, so + * only allow additions if the dictionary + * is the same as at the beginning of the task. + */ + if (!errcnt) { + if (parse_state != PARSE_PARAMS) { + if (currentask->t_topd != topd) + cl_error (E_UERR, illegalvar); + last_parm = currentask->t_pfp->pf_lastpp; + } + } + + /* Increment bracelevel temporarily to defeat command + * mode, in case this is an in-line declaration and + * lexmodes=yes. + */ + bracelevel += PBRACE; + tbrace++; + + } var_decl_list EOST { + /* Update dictionary to include these definitions. + */ + if (!errcnt) { + if (parse_state != PARSE_PARAMS) { + currentask->t_topd = topd; + last_parm = 0; + } + } + + /* Restore command mode */ + bracelevel -= PBRACE; + tbrace--; + } + ; + +typedefs: Y_BOOL { vartype = V_BOOL; } + | Y_STRING { vartype = V_STRING; } + | Y_REAL { vartype = V_REAL; } + | Y_FILE { vartype = V_FILE; } + | Y_GCUR { vartype = V_GCUR; } + | Y_IMCUR { vartype = V_IMCUR; } + | Y_UKEY { vartype = V_UKEY; } + | Y_PSET { vartype = V_PSET; } + | Y_INT { vartype = V_INT; } + | Y_STRUCT { vartype = V_STRUCT; } + ; + +var_decl_list: var_decl_plus + | var_decl_plus DELIM var_decl_list + ; + +var_decl_plus: var_decl { + if (!errcnt) { + if (pp != NULL) { + if (n_aval > 1) + pp->p_type |= PT_ARRAY; + + if (pp->p_type & PT_ARRAY) + do_arrayinit (pp, n_aval, index_cnt); + else + do_scalarinit (pp, inited); + } + } + } + + /* Semi-colon in following rule is not input by user, but + * rather by lexical analyzer to help close compound + * statements. + */ + | var_decl '{' options_list ';' '}' { + if (!errcnt) { + if (pp != NULL) { + if (!do_params) + cl_error (E_UERR, badparm, pp->p_name); + + if (n_aval > 1) + pp->p_type |= PT_ARRAY; + + if (pp->p_type & PT_ARRAY) + do_arrayinit (pp, n_aval, index_cnt); + else + do_scalarinit (pp, n_aval); + } + } + } + ; + +var_decl: var_def { + inited = NO; + n_aval = 0; + } + | var_def '=' { + n_aval = 0; + } + init_list { + inited = YES; + } + ; + +var_def : var_name { + index_cnt = 0; + if (!errcnt) + pp = initparam (stkop($1), do_params, vartype, varlist); + } + | var_name { + int itemp; + + if (!errcnt) { + pp = initparam (stkop($1), do_params, vartype, varlist); + + if (pp != NULL) { + itemp = (pp->p_type & OT_BASIC) == pp->p_type; + itemp = itemp && !varlist; + if (itemp) + pp->p_type |= PT_ARRAY; + else + cl_error (E_UERR, inval_arr, pp->p_name); + } + } + } + '[' init_index_list ']' + ; + +var_name: param { + varlist = NO; + index_cnt = 0; + } + | '*' param { + if (!do_params) { + eprintf (locallist); + EYYERROR; + } + varlist = YES; + index_cnt = 0; + $$ = $2; + } + ; + +init_index_list: + /* A null index list means get the length of the array + * from the initializer. + */ + | init_index_range + | init_index_list DELIM init_index_range + ; + +init_index_range: + const { + if (!errcnt) { + if (pp != NULL) { + if (stkop($1)->o_type == OT_INT) { + push (stkop($1)->o_val.v_i); + push (1); + } else if (maybeindex) { + /* Confusion between sexagesimal and index + * range. Maybeindex is set only when operand + * is real. + */ + int i1,i2; + sexa_to_index (stkop($1)->o_val.v_r, &i1, &i2); + push (i2-i1+1); + push (i1); + } else { + eprintf (inv_index, pp->p_name); + EYYERROR; + } + index_cnt++; + } + } + } + | const ':' const { + if (!errcnt) { + if (pp != NULL) { + if (stkop($1)->o_type != OT_INT || + stkop($3)->o_type != OT_INT) + cl_error (E_UERR, inv_index, pp->p_name); + else { + push (stkop($3)->o_val.v_i - + stkop($1)->o_val.v_i + 1); + push (stkop($1)->o_val.v_i); + } + index_cnt++; + } + } + } + ; + +init_list: init_elem + | init_list DELIM init_elem + ; + +init_elem: const { + if (!errcnt) { + if (pp != NULL) { + push (stkop($1) ); + n_aval++; + } + } + } + | Y_CONSTANT LP const RP /* PL/I notation. */ + { + int cnt; + + if (!errcnt) + if (pp != NULL) { + if (stkop($1)->o_type != OT_INT) + cl_error (E_UERR, arrdeferr, pp->p_name); + + cnt = stkop($1)->o_val.v_i; + if (cnt <= 0) + cl_error (E_UERR, arrdeferr, pp->p_name); + + while (cnt-- > 0) { + push (stkop($3)); + n_aval++; + } + } + } + ; + +const : Y_CONSTANT + | number + ; + +/* The parser and lexical analyzer don't see negative numbers as an + * entity. So we must join signs to their constants. + */ +number : sign Y_CONSTANT { + if (stkop($2)->o_type == OT_INT) { + stkop($2)->o_val.v_i *= $1; + $$ = $2; + } else if (stkop($2)->o_type == OT_REAL) { + stkop($2)->o_val.v_r *= $1; + $$ = $2; + } else { + eprintf ("Invalid constant in declaration.\n"); + EYYERROR; + } + } + ; + +sign : '+' { $$ = 1; } + | '-' { $$ = -1; } + +options_list: init_list DELIM options { + /* Check if we already had an initialization. + */ + if (!errcnt) { + if (inited && pp != NULL) { + eprintf (twoinits, pp->p_name); + EYYERROR; + } + } + } + | init_list { + if (!errcnt) { + if (inited && pp != NULL) { + eprintf (twoinits, pp->p_name); + EYYERROR; + } + } + } + | options + ; + +options : option + | options DELIM option + ; + +option : Y_IDENT '=' const { + if (!errcnt) + if (pp != NULL) + do_option (pp, stkop($1), stkop($3)); + } + ; + +begin_stmt: Y_BEGIN NL + ; + +/* In normal expressions, a param means the name of a parameter, but in + * command line arguments, it may be a string constant. Pull out param + * from expr to let the arg rule deal with it specially. + */ + +expr : expr0 + | ref { + if (!errcnt) + compile (PUSHPARAM, stkop($1)->o_val.v_s); + } + ; + +/* EXPR0 is everything but a simple parameter. This is needed for argument + * lists so that a simple parameter may be treated as a special case of a + * string constant. EXPR1 also excludes constants. This is needed + * to eliminate ambiguities in the grammar which would arise from + * the handling of the lexical ambiguity of sexagesimal constants + * and array index ranges. + */ +expr0 : expr1 + | Y_CONSTANT { + if (!errcnt) + compile (PUSHCONST, stkop($1)); + } + | Y_GCUR { + /* "gcur" is both a keyword and a CL global parameter, + * and must be built into the grammar here to permit + * reference of the parameter in expressions. + */ + if (!errcnt) + compile (PUSHPARAM, "gcur"); + } + | Y_IMCUR { + if (!errcnt) + compile (PUSHPARAM, "imcur"); + } + | Y_UKEY { + if (!errcnt) + compile (PUSHPARAM, "ukey"); + } + | Y_PSET { + if (!errcnt) + compile (PUSHPARAM, "pset"); + } + ; + +expr1 : LP expr RP + + | expr '+' opnl expr { + if (!errcnt) + compile (ADD); + } + | expr '-' opnl expr { + if (!errcnt) + compile (SUB); + } + | expr '*' opnl expr { + if (!errcnt) + compile (MUL); + } + | expr '/' opnl expr { + if (!errcnt) + compile (DIV); + } + | expr YOP_POW opnl expr { + if (!errcnt) + compile (POW); + } + | expr '%' opnl expr { + struct operand o; + if (!errcnt) { + o.o_type = OT_INT; + o.o_val.v_i = 2; + compile (PUSHCONST, &o); + compile (INTRINSIC, "mod"); + } + } + | expr YOP_CONCAT opnl expr { + if (!errcnt) + compile (CONCAT); + } + | expr '<' opnl expr { + if (!errcnt) + compile (LT); + } + | expr '>' opnl expr { + if (!errcnt) + compile (GT); + } + | expr YOP_LE opnl expr { + if (!errcnt) + compile (LE); + } + | expr YOP_GE opnl expr { + if (!errcnt) + compile (GE); + } + | expr YOP_EQ opnl expr { + if (!errcnt) + compile (EQ); + } + | expr YOP_NE opnl expr { + if (!errcnt) + compile (NE); + } + | expr YOP_OR opnl expr { + if (!errcnt) + compile (OR); + } + | expr YOP_AND opnl expr { + if (!errcnt) + compile (AND); + } + | YOP_NOT expr { + if (!errcnt) + compile (NOT); + } + | '-' expr %prec UMINUS { + if (!errcnt) + compile (CHSIGN); + } + + | Y_SCAN LP { + /* Free format scan. */ + if (!errcnt) + push (0); /* use control stack to count args */ + } scanarg RP { + if (!errcnt) { + struct operand o; + o.o_type = OT_INT; + o.o_val.v_i = pop(); /* get total number of args*/ + compile (PUSHCONST, &o); + compile (SCAN); + } + } + | Y_SCANF LP { + /* Formatted scan. */ + if (!errcnt) + push (0); /* use control stack to count args */ + } scanfmt DELIM scanarg RP { + if (!errcnt) { + struct operand o; + + /* Compile number of arguments. */ + o.o_type = OT_INT; + o.o_val.v_i = pop(); + compile (PUSHCONST, &o); + + compile (SCANF); + } + } + + | Y_FSCAN LP { + /* Free format scan from a parameter. */ + if (!errcnt) + push (0); /* use control stack to count args */ + } scanarg RP { + if (!errcnt) { + struct operand o; + o.o_type = OT_INT; + o.o_val.v_i = pop(); /* get total number of args*/ + compile (PUSHCONST, &o); + compile (FSCAN); + } + } + + | Y_FSCANF LP Y_IDENT DELIM { + /* Formatted scan from a parameter. + * fscanf (param, format, arg1, ...) + */ + if (!errcnt) { + compile (PUSHCONST, stkop ($3)); + push (1); /* use control stack to count args */ + } + } scanfmt DELIM scanarg RP { + if (!errcnt) { + struct operand o; + + /* Compile number of arguments. */ + o.o_type = OT_INT; + o.o_val.v_i = pop(); + compile (PUSHCONST, &o); + + compile (FSCANF); + } + } + + | intrinsx LP { + if (!errcnt) + push (0); /* use control stack to count args */ + } intrarg RP { + if (!errcnt) { + struct operand o; + o.o_type = OT_INT; + o.o_val.v_i = pop(); + compile (PUSHCONST, &o); + compile (INTRINSIC, stkop($1)->o_val.v_s); + } + } + ; + +/* Variable types are keywords, so any types which are also intrinsic + * functions are added here. + */ +intrinsx: intrins + | Y_INT { + /* The YACC value of this must match normal intrinsics + * so we must generate an operand with the proper + * string. + */ + if (!errcnt) + $$ = addconst ("int", OT_STRING); + } + | Y_REAL { + if (!errcnt) + $$ = addconst ("real", OT_STRING); + } + ; + +scanfmt : expr { + if (!errcnt) { + push (pop() + 1); /* inc num args */ + } + } + ; + +scanarg : /* empty. This is bad for scan but we don't want to + * generate a cryptic syntax error. See also intrarg. + * This rule reduces the strings from right to left. + * Note the lexical analyzer strips optional newlines + * after comma delimiters, so we don't need an opnl here. + */ + | Y_IDENT { + if (!errcnt) { + compile (PUSHCONST, stkop ($1)); + push (pop() + 1); /* inc num args */ + } + } + | Y_IDENT DELIM scanarg { + if (!errcnt) { + compile (PUSHCONST, stkop ($1)); + push (pop() + 1); /* inc num args */ + } + } + ; + +intrarg : /* empty. this is to allow () but it also allows + * (x,,x). may want to prune this out. + */ + | expr { + if (!errcnt) + push (pop() + 1); /* inc num args */ + } + | intrarg DELIM expr { + if (!errcnt) + push (pop() + 1); /* inc num args */ + } + ; + + +/* Statements. */ + +stmt : c_stmt + | assign EOST + | cmdlist EOST + | immed EOST + | inspect EOST + | osesc EOST + | popstk EOST + | if + | ifelse + | while + | for + | switch + | case + | default + | next EOST + | break EOST + | goto EOST + | return EOST + | label_stmt + | nullstmt + ; + + /* A compound statement may be followed by zero or one + * newlines. + */ +c_stmt : c_blk + | c_blk NL + ; + +c_blk : '{' { + bracelevel++; + } s_list opnl { + --bracelevel; + } '}' + ; + +s_list : /* empty */ + | s_list opnl xstmt + ; + +/* Put "implicit" parentheses around right hand side of assignments to + * permit easy arithmetic even with lexmodes=yes. + */ +assign : ref equals expr0 { + --parenlevel; + if (!errcnt) + compile (ASSIGN, stkop($1)->o_val.v_s); + } + | ref equals ref { + /* Old code pushed a constant rather than a param + * when not within braces. This doesn't seem + * to be what most people want. + */ + --parenlevel; + if (!errcnt) { + compile (PUSHPARAM, stkop($3)->o_val.v_s); + compile (ASSIGN, stkop($1)->o_val.v_s); + } + } + | ref { + parenlevel++; + } + assign_oper expr { + --parenlevel; + if (!errcnt) + compile ($3, stkop($1)->o_val.v_s); + } + ; + + /* Breaking out the '=' avoids grammar ambiguities. + */ +equals : '=' { + parenlevel++; + } + ; + +assign_oper: YOP_AOADD { $$ = ADDASSIGN; } + | YOP_AOSUB { $$ = SUBASSIGN; } + | YOP_AOMUL { $$ = MULASSIGN; } + | YOP_AODIV { $$ = DIVASSIGN; } + | YOP_AOCAT { $$ = CATASSIGN; } + ; + +cmdlist : command { + npipes = 0; + } cmdpipe { + if (!errcnt) { + compile (EXEC); + if (npipes > 0) + compile (RMPIPES, npipes); + } + } + ; + +cmdpipe : /* empty */ + | cmdpipe pipe { + /* Pipefiles must be allocated at run time using a stack + * to permit pipe commands within loops, and to permit + * scripts called in a pipe to themselves contain pipe + * commands. ADDPIPE allocates a new pipefile on the + * pipe stack and pushes its name on the operand stack. + * GETPIPE pushes the pipefile at the top of the pipe + * stack onto the operand stack. RMPIPES removes N pipes + * from the pipe stack, and deletes the physical pipefiles. + */ + + if (!newstdout) { + /* When the runtime code creates the pipe it needs to + * know the identity of the two tasks sharing the pipe + * to determine what type of pipe to create (text or + * binary). Save the pc of the ADDPIPE instruction + * so that we can backpatch it below with a pointer to + * the name of the second task in the pipe (ADDPIPE + * will be called during startup of the first task + * hence will know its name). + */ + pipe_pc = compile (ADDPIPE, NULL); + + if ($2 == 1) + compile (REDIR); + else + compile (ALLREDIR); + compile (EXEC); + + } else { + eprintf ("multiple redirection\n"); + YYERROR; + } + + } command { + /* Compile the GETPIPE instruction with the name of the + * second task in the current pipe, and backpatch the + * matching ADDPIPE instruction with the PC of the GETPIPE. + */ + (coderef(pipe_pc))->c_args = compile (GETPIPE, curr_task); + compile (REDIRIN); + npipes++; /* Overflow checking is in ADDPIPE */ + } + ; + +pipe : '|' opnl { + $$ = 1; + } + | Y_ALLPIPE opnl { + $$ = 2; + } + ; + +command : tasknam { + char *ltname; + + ltname = stkop($1)->o_val.v_s; + compile (CALL, ltname); + strcpy (curr_task, ltname); + + /* The FPRINT task is special; the first arg + * is the destination and must be compiled as + * a string constant no matter what. Set flag + * so that 'arg' compiles PUSHCONST. + */ + printstmt = (strcmp (ltname, "fprint") == 0); + + /* Ditto with SCAN; all the arguments are call by + * reference and must be compiled as string constants. + */ + scanstmt = (strcmp (ltname, "scan") == 0 || + strcmp (ltname, "scanf") == 0); + + absmode = 0; + posit = 0; + newstdout = 0; + parenlevel = 0; + } BARG { + inarglist = 1; + } args EARG { + inarglist = 0; + parenlevel = 0; + scanstmt = 0; + } + ; + +args : DELIM { + /* (,x) equates to nargs == 2. Call posargset with + * negative dummy argument to bump nargs. + */ + if (!errcnt) { + compile (POSARGSET, -1); + posit++; + printstmt = 0; + scanstmt = 0; + } + } arglist + | arglist + ; + +arglist : arg + | arglist DELIM arg + ; + +arg : /* nothing - compile a null posargset to bump nargs */ + { + if (!errcnt) { + if (posit > 0) { /* not first time */ + compile (POSARGSET, -posit); + printstmt = 0; + scanstmt = 0; + } + posit++; + } + } + | expr0 { + if (absmode) { + eprintf (posfirst); + EYYERROR; + } else + if (!errcnt) + compile (POSARGSET, posit++); + } + | ref { + if (absmode) { + eprintf (posfirst); + EYYERROR; + } else if (!errcnt) { + if (scanstmt) { + char pname[SZ_FNAME]; + char *pk, *t, *p, *f; + struct pfile *pfp; + struct operand o; + + /* If no task name specified check the pfile for + * the task containing the scan statement for the + * named parameter. + */ + breakout (stkop($1)->o_val.v_s, &pk, &t, &p, &f); + pfp = currentask->t_pfp; + if (*pk == NULL && *t == NULL && + pfp && paramfind(pfp,p,0,1)) { + + sprintf (pname, "%s.%s", + currentask->t_ltp->lt_lname, p); + if (*f) { + strcat (pname, "."); + strcat (pname, f); + } + } else + strcpy (pname, stkop($1)->o_val.v_s); + + o = *(stkop($1)); + o.o_val.v_s = pname; + compile (PUSHCONST, &o); + compile (INDIRPOSSET, posit++); + + } else if (parenlevel == 0 || printstmt) { + compile (PUSHCONST, stkop($1)); + compile (INDIRPOSSET, posit++); + /* only first arg of fprint stmt is special. */ + printstmt = 0; + + } else { + compile (PUSHPARAM, stkop($1)->o_val.v_s); + compile (POSARGSET, posit++); + } + } + } + | ref '=' expr0 { + absmode++; + if (!errcnt) + compile (ABSARGSET, stkop($1)->o_val.v_s); + } + | ref '=' ref { + absmode++; + if (!errcnt) { + if (parenlevel == 0) { + compile (PUSHCONST, stkop($3)); + compile (INDIRABSSET, stkop($1)->o_val.v_s); + } else { + compile (PUSHPARAM, stkop($3)->o_val.v_s); + compile (ABSARGSET, stkop($1)->o_val.v_s); + } + } + } + | param '+' { + absmode++; + if (!errcnt) + compile (SWON, stkop($1)->o_val.v_s); + } + | param '-' { + absmode++; + if (!errcnt) + compile (SWOFF, stkop($1)->o_val.v_s); + } + | '<' file { + if (!errcnt) + compile (REDIRIN); + } + | '>' file { + newstdout++; + if (!errcnt) + compile (REDIR); + } + | Y_ALLREDIR file { + newstdout++; + if (!errcnt) + compile (ALLREDIR); + } + | Y_APPEND file { + newstdout++; + if (!errcnt) + compile (APPENDOUT); + } + | Y_ALLAPPEND file { + newstdout++; + if (!errcnt) + compile (ALLAPPEND); + } + | Y_GSREDIR file { + if (!errcnt) + compile (GSREDIR, stkop($1)->o_val.v_s); + } + ; + +file : expr0 { + absmode++; + /* constant already pushed by expr0. + */ + } + | param { + absmode++; + if (!errcnt) { + if (parenlevel == 0) + compile (PUSHCONST, stkop($1)); + else + compile (PUSHPARAM, stkop($1)->o_val.v_s); + } + } + ; + +immed : equals expr0 { + --parenlevel; + if (!errcnt) + compile (IMMED); + } + | equals ref { + --parenlevel; + if (!errcnt) + compile (INSPECT, stkop($2)->o_val.v_s); + } + ; + +inspect : ref equals { + --parenlevel; + if (!errcnt) + compile (INSPECT, stkop($1)->o_val.v_s); + } + ; + +osesc : Y_OSESC { + if (!errcnt) + compile (OSESC, stkop($1)->o_val.v_s); + } + ; + +popstk : equals { + --parenlevel; + if (!errcnt) + compile (IMMED); + } + ; + +if : if_stat { + /* pop BIFF addr and set branch to just after statement + */ + XINT biffaddr; + if (!errcnt) { + biffaddr = pop(); + coderef (biffaddr)->c_args = pc - biffaddr - 3; + } + } + ; + +if_stat : Y_IF LP expr RP { + /* save BIFF addr so branch can be filled in + */ + if (!errcnt) + push (compile (BIFF, 0)); + } opnl xstmt { + /* The shift/reduce conflict in the IF-IF/ELSE + * construct can cause errors in compilation + * because the IF statement can also be a + * terminal symbol, i.e. it may be all that + * is parsed in one call to the parser. + * The parser must look ahead one token + * to find if there is an else statement + * following. If there is no following + * token an EOF may be detected prematurely. + * When the IF statement is being parsed not + * inside any braces, then when the next token + * is not an ELSE care must be taken that this + * token is seen on a subsequent invocation + * of the parser. The `ifseen' flag is + * used within the support for the lexical + * analyzer located in `history.c'. + */ + if (cldebug) + eprintf ("ytab: setting ifseen=yes\n"); + + if (currentask->t_flags & T_INTERACTIVE) + ifseen = ip_cmdblk; + else + ifseen = cmdblk; + } + ; + +ifelse : if_stat Y_ELSE { + XINT biffaddr; + + ifseen = NULL; + if (!errcnt) { + /* Pop and save BIFF address, compile and push addr + * of GOTO, and set BIFF branch to just after GOTO. + */ + biffaddr = pop(); + push (compile (GOTO, 0)); + coderef (biffaddr)->c_args = pc - biffaddr - 3; + } + } opnl xstmt { + XINT gotoaddr; + if (!errcnt) { + /* Pop GOTO addr and set branch to just after statement + */ + gotoaddr = pop(); + coderef (gotoaddr)->c_args = pc - gotoaddr - 3; + } + } + ; + +while : Y_WHILE LP { + /* Save starting addr of while expression. + */ + if (!errcnt) { + push (pc); + loopincr(); + } + } expr RP { + /* Save BIFF addr so branch can be filled in. + */ + if (!errcnt) + push (compile (BIFF, 0)); + } opnl xstmt { + XINT biffaddr; + + if (!errcnt) { + /* Pop and save addr of BIFF instruction. */ + biffaddr = pop(); + /* Pop addr of expression and build a goto there. */ + compile (GOTO, pop() - pc - 3); + /* Now can set BIFF branch to just after statement.*/ + coderef (biffaddr)->c_args = pc - biffaddr - 3; + loopdecr(); + } + } + ; + + /* The line of code: + * + * for (e1, e2, e3) stmt + * + * is compiled into: + * + * e1 + * loop1: if (!e2) goto end + * goto loop3 + * loop2: e3 + * goto loop1 + * loop3: stmt + * goto loop2 + * end: + * + * Note that e1 and e3 are assignments while e2 is an expression. + */ + +for : Y_FOR LP opnl xassign ';' opnl { + if (!errcnt) + push(pc); /* Loop1: */ + } + xexpr ';' opnl { + if (!errcnt) { + if (for_expr) + ppush (compile(BIFF, 0)); /* if (!e2) */ + + /* Add 3 to skip following GOTO. + */ + ppush (pc+3); /* Loop2: */ + ppush (compile(GOTO,0)); /* goto Loop3 */ + + /* Save current location as the destination + * for NEXT statements. + */ + loopincr(); + } + } + xassign RP opnl { + XINT stmtaddr; + + if (!errcnt) { + stmtaddr = pop(); + compile (GOTO, stmtaddr-pc-3); /* Goto loop1 */ + stmtaddr = pop(); + coderef(stmtaddr)->c_args = pc - stmtaddr - 3; + } + } + stmt { + XINT stmtaddr; + + if (!errcnt) { + stmtaddr = pop(); + compile (GOTO, stmtaddr-pc-3); /* goto loop2 */ + + if (for_expr) { + stmtaddr = pop(); + coderef(stmtaddr)->c_args = pc - stmtaddr - 3; + } + loopdecr(); + } + } + ; + +/* The following allow skipping of fields in the FOR statement. + */ + +xassign : assign + | /* empty */ + ; + +xexpr : expr { + for_expr = YES; + } + | /* empty */ { + for_expr = NO; + } + ; + + /* The compiled code for the switch statement + * consists of a SWITCH, followed by a series of + * CASE and DEFAULT blocks, followed by a jump table. + * The first operand in each CASE and DEFAULT block + * is a CASE or DEFAULT operand which is never + * executed, but is used to store the values which + * will enter this block. Executable statements + * follow. + * + * The jump table consists of the addresses of the + * CASE and DEFAULT blocks. The DEFAULT block + * comes first, and is 0 if no default has + * been given. The list of addresses is terminated + * by a 0 address. + * + * The last statement of each CASE and DEFAULT + * statement is a branch back to a GOTO following + * the SWITCH. This GOTO points to after the jumptable. + */ + +switch : Y_SWITCH opnl LP opnl expr opnl RP opnl + { + if (!errcnt) { + push (compile(SWITCH)); + + /* Compile GOTO which will branch past end of + * switch. This is needed if there is no DEFAULT. + */ + compile (GOTO, 0); + } + } xstmt { + /* Set up jumptable and pop space on stack. + */ + if (!errcnt) + setswitch(); + } + ; + +case : Y_CASE { + if (!errcnt) { + ncaseval = 0; + if (!in_switch()) { + eprintf ("Improper CASE statement.\n"); + EYYERROR; + } + } + } const_expr_list ':' opnl { + XINT pcase; + + if (!errcnt) { + pcase = compile (CASE, ncaseval); + + /* Fill in argument list. + */ + caseset (&(coderef(pcase)->c_args), ncaseval); + push (pcase); + } + } xstmt { + /* Branch to end of switch block + */ + if (!errcnt) + push (compile(GOTO, 0)); + } + ; + +default : Y_DEFAULT ':' opnl { + /* Compile an operand to store the current PC. + */ + if (!errcnt) { + if (!in_switch()) { + eprintf ("Improper DEFAULT statement.\n"); + EYYERROR; + } + push (compile(DEFAULT)); + } + } xstmt { + /* Branch past jump table. + */ + if (!errcnt) + push (compile(GOTO, 0)); + } + ; + +next : Y_NEXT { + /* All NEXT statements are backward references, + * so we simply store the addresses in an array. + */ + if (!errcnt) { + if (nestlevel) + compile (GOTO, nextdest[nestlevel-1]-pc-3); + else { + eprintf ( "NEXT outside of loop.\n"); + EYYERROR; + } + } + } + ; + +break : Y_BREAK { + /* Each BREAK is a forward reference. For the + * first BREAK in each loop we compile a + * GOTO statement which will be the object of + * all BREAK statements within the loop. When + * the loop is terminated the target of this + * GOTO will be set. + */ + int dest; + + if (!errcnt) { + if (!nestlevel) { + eprintf ("Break outside of loop.\n"); + EYYERROR; + } else if ((dest = brkdest[nestlevel-1]) != 0) + compile (GOTO, dest-pc-3); + else { + brkdest[nestlevel-1] = pc; + compile (GOTO, 0); + } + } + } + ; + +return : Y_RETURN { + if (!errcnt) + compile (END); + } + | Y_RETURN expr { + /* Return values currently not implemented. + */ + eprintf ("Warning: return value ignored.\n"); + if (!errcnt) + compile (END); + } + ; + + /* Require end to terminate with a new-line, because + * it should be at the end of the file. + */ +end_stmt: Y_END NL { + bracelevel -= PBRACE; + if (bracelevel < 0) { + eprintf ("Too few left braces.\n"); + EYYERROR; + } else if (bracelevel > 0) { + eprintf ("Too few right braces.\n"); + EYYERROR; + } + } + ; + +label_stmt: Y_IDENT ':' opnl { + /* Put symbol in table in dictionary and + * process indirect references if present. + */ + struct label *l; + + if (!errcnt) { + l = getlabel (stkop($1)); + + if (l == NULL) { + l = setlabel (stkop($1)); + l->l_loc = pc; + } else if (l->l_defined) { + eprintf ("Identical labels.\n"); + EYYERROR; + } else { + /* Get this GOTO out of the + * indirect list so we can use + * the argument as the destination + */ + XINT gotopc; + gotopc = l->l_loc; + unsetigoto (gotopc); + + /* Fix the indirect reference. + */ + coderef(gotopc)->c_args = pc - gotopc - 3; + } + (l->l_defined)++; + } + } + xstmt + ; + +goto : Y_GOTO Y_IDENT { + /* Get the address corresponding to the label. + */ + struct label *l; + + if (!errcnt) { + l = getlabel (stkop($2)); + + if (l != NULL) + compile (GOTO, l->l_loc - pc - 3); + else { + /* Ready for indirect GOTO + */ + l = setlabel (stkop($2)); + l->l_loc = pc; + setigoto (compile(GOTO, 0)); + l->l_defined = 0; + } + } + } + ; + +nullstmt: ';' + | ';' NL + ; + +/* xstmt is defined so that to handle implicit do loops created by + * open array references e.g. a[*,3]=a[3,*]. + */ + +xstmt : /* empty */ { + /* Save pc before compiling statement for loop back + */ + stmt_pc = pc; + n_oarr = 0; + i_oarr = 0; + ifseen = NULL; + } + stmt { + /* If there was an open reference compile the + * loop increment and goback. + */ + XINT push_pc; + + if (!errcnt) { + if (n_oarr) { + compile (INDXINCR, stmt_pc-pc-4, 2*n_oarr+1); + + /* We are going to store initialization + * info for the implicit loop here. + * It is loopincr's responsibility to + * branch around it. This data is what + * should be pointed to by the special + * PUSHINDEX compiled at the first open + * array reference. + */ + push_pc = pop(); /* Location of PUSHINDEX */ + coderef(push_pc)->c_args = pc - push_pc - 3; + + stack[pc++] = n_oarr; + for (i_oarr=0; i_oarrt_bascode; + if (parse_state != PARSE_PARAMS) + compile (END); + + topd = currentask->t_topd; + topcs = currentask->t_topcs; + + /* Unlink any added parms. Resetting of topd will + * already have reclaimed space. + */ + if (last_parm) { + last_parm->p_np = NULL; + currentask->t_pfp->pf_lastpp = last_parm; + last_parm = NULL; + } + } + + /* Tell user about the syntax error, printing the + * offending line and position if possible. + */ + if (currentask->t_flags & T_SCRIPT) + eprintf ("** Syntax error, line %d\n", + currentask->t_scriptln); + else + eprintf ("** Syntax error\n"); + p_position(); + + if (!(currentask->t_flags & T_SCRIPT)) { + /* If interactive, we're finished if not within braces. + */ + if (!bracelevel) + YYACCEPT; + } + + /* Note that we do not call cl_error() here to abort, but + * continue on parsing the script for more syntax errors. + */ + if (++errcnt > MAX_ERR) + cl_error (E_UERR, "Too many syntax errors."); + } + ; + +const_expr_list : const_expr + | const_expr DELIM const_expr_list + ; + +const_expr : Y_CONSTANT { + if (!errcnt) { + push(stkop($1)) ; + ncaseval++; + } + } + ; + + /* Use opnl when blank lines are permitted, + * or where a statement may be broken into more + * than one line. The lexical analyzer (actually + * get_command in history.c) ensures that all blank + * lines are deleted. So we don't have to use + * a recursive definition here. + */ + +opnl : /* empty */ + | NL + ; + +ref : param { + int dim, d, i1, i2, mode; + + /* In command arguments, when not in parentheses + * we just pass the param as a string constant. + */ + if (!errcnt) { + lastref = NO; + if (!inarglist || parenlevel) { + i_oarr = 0; + index_cnt = 0; + + strncpy (curr_param, stkop($1)->o_val.v_s, + SZ_FNAME); + + /* If a '.' is found in the name we have a + * reference to an external task, or to a + * specific field. In these cases we don't + * want implicit looping. + */ + if (index (curr_param, '.') == NULL) { + if ((dim = get_dim (curr_param)) > 0) { + lastref = YES; + for (d = 0; d < dim; d++) { + getlimits (curr_param, d, &i1, &i2); + mode = make_imloop (i1, i2); + if (mode) + compile (PUSHINDEX, -1); + else + push (compile(PUSHINDEX, 0)); + } + n_oarr = dim; + } + } + } + } + } + | param { + if (!errcnt) { + strncpy (curr_param, stkop($1)->o_val.v_s, SZ_FNAME); + index_cnt = 0; + } + } + '[' index_list ']' + { + if (i_oarr > 0 && n_oarr == 0) + n_oarr = i_oarr; + i_oarr = 0; + lastref = YES; + } + ; + +index_list: index { + index_cnt = 1; + } + | index { + index_cnt++; + } + DELIM index_list + ; + +index : expr1 { + if (!errcnt) + compile (PUSHINDEX, 0); + } + | ref /* This isn't included in expr1 */ + { + if (!errcnt) { + compile (PUSHPARAM, stkop($1)->o_val.v_s); + compile (PUSHINDEX, 0); + } + } + | '*' { + int i1, i2, mode; + + if (!errcnt) { + if (index(curr_param, '.') != NULL) { + eprintf (exlimits); + EYYERROR; + } + if (getlimits (curr_param, index_cnt, &i1, &i2) + == ERR) { + eprintf ("Implicit index error for %s.\n", + curr_param); + EYYERROR; + } + mode = make_imloop (i1, i2); + if (mode) + compile (PUSHINDEX, mode); + else + push (compile (PUSHINDEX, mode)); + } + } + | Y_CONSTANT { + /* There is an ambiguity in the grammar between + * sexagesimal constants, and array range references. + * Since the sexagesimal constants are recognized + * in the lexical analyzer we can't just change the + * grammar. The kludge around this is to have + * makeop set a flag telling us that the last + * constant it compiled COULD have been an index + * range. We check the flag here and if it is + * set we convert back and compile an implicit loop + * otherwise we just push the constant. + */ + int i1, i2, mode; + + if (!errcnt) { + if (maybeindex) { + sexa_to_index (stkop($1)->o_val.v_r, &i1, &i2); + mode = make_imloop (i1, i2); + if (mode) + compile (PUSHINDEX, mode); + else + push (compile (PUSHINDEX, mode)); + } else { + compile (PUSHCONST, stkop($1)); + compile (PUSHINDEX, 0); + } + } + } + ; + +/* these are just to make the grammar a bit easier to read. + * can yank them out to shrink parser a bit... + */ + +intrins : Y_IDENT { + $$ = $1; + } + ; + +param : Y_IDENT { + $$ = $1; + } + ; + +tasknam : Y_IDENT { + $$ = $1; + } + ; + +EOST : NL + | ';' { + /* If statements are delimited by ';'s, do not execute + * until next newline EOST is received. + */ + sawnl = 0; + } + ; + +DELIM : ',' + ; + +BARG : /* empty */ + | LP + ; + +EARG : /* empty */ + | RP + ; + +/* These eliminate several interior actions. + */ + +LP : '(' { parenlevel++; } + ; + +RP : ')' { --parenlevel; } + ; + +NL : Y_NEWLINE { sawnl = 1; } + ; + +%% + +#include "lexyy.c" +#include "lexicon.c" diff --git a/pkg/cl/history.c b/pkg/cl/history.c new file mode 100644 index 00000000..1cdbe050 --- /dev/null +++ b/pkg/cl/history.c @@ -0,0 +1,1159 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#define import_fset +#define import_ctype +#include + +#include "config.h" +#include "errs.h" +#include "mem.h" +#include "operand.h" +#include "param.h" +#include "task.h" +#include "clmodes.h" +#include "grammar.h" +#include "proto.h" + + +/* + * HISTORY.C -- Routines for character input to the parser (actually, + * the lexical analyser). Includes the history mechanism, the logfile, + * and prompting. + */ + +extern int cldebug; + +#define HISTCHAR '^' /* primary history metacharacter */ +#define FIRSTARG '^' /* first argument macro ("^^") */ +#define LASTARG '$' /* last argument macro ("^$") */ +#define ALLARGS '*' /* all arguments macro ("^*") */ +#define ARGCHARS "$^*" /* argument substitution chars */ +#define MATCH_ANYWHERE '?' /* match string anywhere in cmd */ +#define MATCH_ALL 'g' /* match all occurrences */ +#define NO_EXECUTE ":p" /* print but do not execute command */ +#define MAXCOL 80 /* form width for formatting output */ +#define SZ_LOGBUF 1024 /* putlog buffer size */ + +#define EOS '\0' +#define NOCLOSURE ">>" /* parser needs more input (pprompt) */ +#define MAX_SHOWHIST 800 /* maximum history cmds to show */ + +/* History, command block, yy_getc, logfile database. + */ +char raw_cmdblk[SZ_CMDBLK+1];/* saves raw command for history (for scripts)*/ +char cmdblk[SZ_CMDBLK+1]; /* command block buffer */ +char *op_cmdblk=cmdblk; /* next output line in cmdblk */ +char *ip_cmdblk=cmdblk; /* next input char in cmdblk */ +int cmdblk_line=0; /* line number within cmd block */ +int cmdblk_save=0; /* set if cmdblk filled interactively */ + +char histbuf[SZ_HISTBUF+1]; /* history buffer */ +char *op_hist=histbuf; /* next location in history buffer */ +int histbuf_full=0; /* set when buffer wraps around */ +int share_logfile=SHARELOG; /* share logfile with other processes? */ + +FILE *logfp=NULL; /* file pointer for command logfile */ +int histnum = 0; /* history command block number */ +int history_number; /* the current history record */ + +extern int _lexmodes; /* enable lexical mode switching */ +extern char *ifseen; /* Processing an IF statement? */ + + +/* YY_GETC -- Called by the modified yylex() "input" macro in the lexical + * analysis stage of the parser to get the next character from the input + * stream. When EOF is reached on the stream, add the "bye" command to + * the logfile. + */ +int +yy_getc ( + FILE *fp +) +{ + register char ch; + + while ((ch = *ip_cmdblk++) == EOS) + if (get_command (fp) == EOF) { + if (currentask->t_flags & T_INTERACTIVE) + if (log_commands()) + put_logfile ("bye\n"); + return (EOF); + } + + return (ch); +} + + +/* YY_STARTBLOCK -- Terminate the last command block and start a new one. + * Save old command block in history (if interactive) and in logfile (if + * interactive, logging is enabled, and logflag argument is true). Even + * if logging is enabled, a command will not be logged which aborts or is + * interrupted. + */ +void +yy_startblock ( + int logflag +) +{ + register char *ip; + + if (cldebug) + eprintf ("startblock (%d)\n", logflag); + + /* Log cmdblk only if it was filled by an interactive task. We must + * make the test when the new block is initialized since the write is + * delayed. + */ + if (cmdblk_save) { + /* Do not record commands which consist only of whitespace. + */ + for (ip=cmdblk; isspace (*ip); ip++) + ; + if (*ip != EOS) { + /* Use the raw_cmdblk, saved in get_command(). + */ + put_history (raw_cmdblk); + if (logflag && log_commands()) + put_logfile (raw_cmdblk); + } + } + + if (cldebug) + eprintf ("startblock: ifseen=%d\n", ifseen); + + if (!ifseen) { + ip_cmdblk = op_cmdblk = cmdblk; + *ip_cmdblk = EOS; + } + cmdblk_line = 0; + cmdblk_save = (currentask->t_flags & T_INTERACTIVE); + + /* Mode switching of the lexical analyzer is enabled by this call + * if the CL parameter lexmodes is set. Called between blocks + * entered interactively and also during error recovery. + */ + lexinit(); +} + + +/* CURCMD -- Return a pointer to the command block currently being interpreted. + */ +char * +curcmd (void) +{ + return (cmdblk); +} + + +/* GET_COMMAND -- Get command line from the input stream. If not interactive, + * all we do is read the line into the cmdblk buffer. If called when parsing + * command input to an interactive task, we must output a prompt before + * reading in the command line. The prompt changes depending on whether or + * not the command is the first in a command block (whether or not we have + * closure). After reading the command, we check if it is a history directive + * and process it if so. Otherwise we must still process it to expand any + * history macros. Ignore all blank or comment lines. These are + * any line in which the first non-blank character is a newline or a + * '#'. This will make some things a bit more efficient, but is + * actually to allow the if/else parsing to work properly. + * + * N.B.: We must directly or indirectly set ip_cmdblk so that yy_getc takes + * the next character from the right place. This is either done directly + * or by a call to yy_startblock. + */ +int +get_command ( + FILE *fp +) +{ + register char *ip, *op; + char raw_cmd[SZ_LINE+1]; /* buffer for raw command line */ + char new_cmd[SZ_CMDBLK+1]; /* temporary for processed cmd */ + int execute=1, temp, status; + + + if (!(currentask->t_flags & T_INTERACTIVE) || + parse_state == PARSE_PARAMS) { + + /* Ensure that searches through string terminate. */ + cmdblk[SZ_LINE] = '\0'; + ip_cmdblk = cmdblk; + + while (YES) { + currentask->t_scriptln++; /* noninteractive mode */ + + status = (fgets (cmdblk, SZ_LINE, fp) == NULL ? EOF : OK); + if (status == EOF) { + cmdblk[0] = '\0'; + break; + } + + /* Check if this is a blank line. */ + for (ip = cmdblk; *ip == ' ' || *ip == '\t'; ip++) + ; + if (*ip == '\n' || *ip == '\0') + continue; + + /* Check for the #{ ... #} lexmode toggle sequences. These + * are matched only at the beginning of a line. #{ sets + * command mode on the command input stream and #} clears it. + */ + if (*ip == '#') { + if (ip == cmdblk) { + if (*(ip+1) == '{') { + lex_setcpumode (fp); + lexinit(); + } else if (*(ip+1) == '}') { + lex_clrcpumode (fp); + lexinit(); + } + } + continue; + } + + break; + } + + if (cldebug || echocmds()) + eprintf ("%s", status == EOF ? "bye\n" : cmdblk); + + return (status); + } + + raw_cmd[SZ_LINE] = '\0'; + while (YES) { + /* Prompt the user for a new command if the input buffer is empty. + * The CL prompt clears raw mode in case it is left in effect by a + * program abort. + */ +input_: + if (c_fstati (fileno(fp), F_UNREAD) == 0) { + if (c_fstati ((XINT)STDIN, F_RAW) == YES) + c_fseti ((XINT)STDIN, F_RAW, NO); + if (cmdblk_line == 0) + pprompt (curpack->pk_name); + else + pprompt (NOCLOSURE); + } + + /* Read the next command line. */ + if (fgets (raw_cmd, SZ_LINE, fp) == NULL) + return (EOF); + + /* Check for the #{ ... #} lexmode toggle sequences. These + * are matched only at the beginning of a line. #{ sets + * command mode on the command input stream and #} clears it. + */ + if (*(ip=raw_cmd) == '#') { + if (*(ip+1) == '{') { + lex_setcpumode (fp); + lexinit(); + } else if (*(ip+1) == '}') { + lex_clrcpumode (fp); + lexinit(); + } + } + + /* Skip leading whitespace. */ + for (ip=raw_cmd; *ip == ' ' || *ip == '\t'; ip++) + ; + + /* For interactive comments, make sure we store them in the + * history and the logfile. This is so that users can add + * comments into the logfile interactively. + */ + if (*ip == '#') { + put_history (raw_cmd); + if (log_commands()) + put_logfile (raw_cmd); + } else if (*ip != '\n' && *ip != '\0') { + cmdblk_line++; + break; + } + } + + /* If history directive, transform the directive into an executable + * command block using the history data. Echo the new command as + * if the user had typed it, for verification. + */ + if (*raw_cmd == HISTCHAR) { + /* Use screen style history editing only if the CL parameter + * "ehinit" contains the boolean variable "verify" (or if the + * cmd is "ehistory", below). + */ + if (eh_verify) + execute = edit_history_directive (raw_cmd+1, new_cmd); + else { + execute = process_history_directive (raw_cmd, new_cmd); + fputs (new_cmd, currentask->t_stdout); + } + + } else if (expand_history_macros (raw_cmd, new_cmd)) { + fputs (new_cmd, currentask->t_stdout); + + } else { + static char ehist[] = "ehistory"; + int n; + + for (n=0, ip=raw_cmd, op=ehist; (*ip == *op); ip++, op++) + n++; + if (n > 0 && isspace (*ip)) { + while (isspace (*ip)) + ip++; + execute = edit_history_directive (ip, new_cmd); + } + } + + /* If user deletes entire line go back and get another command. */ + for (ip=new_cmd; isspace (*ip); ip++) + ; + if (*ip == EOS) { + cmdblk_line = 0; + execute = 1; + goto input_; + } + + /* Now move the processed command into the cmdblk buffer. If there + * is not enough storage remaining in the cmdblk buffer, we have to + * break the actual (large) command block up, calling yy_startblock to + * start a new block, but without changing the line number within the + * block. We must not let the history mechanism limit the size of a + * command block. + */ + op_cmdblk = ip_cmdblk - 1; /* back up to EOS */ + if (strlen (new_cmd) > (cmdblk + SZ_CMDBLK - op_cmdblk)) { + temp = cmdblk_line; + yy_startblock (LOG); + cmdblk_line = temp; + } + ip_cmdblk = op = op_cmdblk; + for (ip=new_cmd; (*op++ = *ip++) != EOS; ) + ; + + /* Save the "raw command" here for use in yy_startblock. This is + * to handle the problem of procedure script parsing overwriting + * the raw command in cmdblk. + */ + strcpy (raw_cmdblk, cmdblk); + + if (!execute) + yy_startblock (NOLOG); + + fflush (currentask->t_stdout); + return (OK); +} + + +/* PROCESS_HISTORY_DIRECTIVE -- Transform a history directive into an + * executable command or command block. There are two classes of + * directives: (1) string substitution editing of the last command block, + * and (2) search for an earlier command by some means and return that. + * If ":p" follows a directive, we generate the command and return false + * (no execute) as the function value. Any text which follows the directive + * is appended to the new command block. + */ +int +process_history_directive ( + char *directive, + char *new_command_block +) +{ + register char *ip, *op, *p; + char last_command_block[SZ_CMDBLK+1]; + int execute=1, edit=0; + int record; + char *rindex(); + + ip = directive + 1; /* skip the '^' */ + op = new_command_block; + + /* Chop the newline. */ + if ((p = rindex (ip, '\n')) != NULL) + *p = EOS; + + /* Scan the directive string to determine whether or not we have + * an edit directive. We have an edit directive if there is a second + * (unescaped) history metacharacter in the directive. + */ + for (p=ip, edit=0; *p != EOS; p++) + if (*p == '\\' && *(p+1) != EOS) + p++; + else if (*p == HISTCHAR) { + edit = 1; + break; + } + + /* Directives "^^", "^str1^str2^", and "^str1^str2^g". */ + if (edit) { + /* Get last command and edit it */ + if (get_history (1, last_command_block, SZ_CMDBLK) == ERR) + cl_error (E_UERR, "Nothing in history buffer to edit"); + ip = directive + + stredit (directive, last_command_block, new_command_block); + + /* Directives "^absnum" and "-relnum". */ + } else if ((*ip == '-' && isdigit (*(ip+1))) || isdigit (*ip)) { + if (*ip == '-') + record = -atoi(ip++); + else + record = histnum - atoi(ip) + 1; + if (get_history (record, new_command_block, SZ_CMDBLK) == ERR) + cl_error (E_UERR, "History record not found"); + while (isdigit (*ip)) + ip++; + + /* Directives "^", "^str", and "^?str". */ + } else + ip = directive + search_history (directive, new_command_block); + + /* Check for the ":p" no execute suffix */ + execute = (strncmp (ip, NO_EXECUTE, strlen(NO_EXECUTE)) != 0); + if (!execute) + ip += strlen (NO_EXECUTE); + + /* Append any text remaining in the history directive to the new + * command block, BEFORE the final newline. + */ + op += strlen (new_command_block); + while (isspace (*(op-1))) + --op; + expand_history_macros (ip, op); + + /* Make sure the new command line ends with a newline. */ + while (*op != EOS) + op++; + while (isspace (*(op-1))) + --op; + *op++ = '\n'; + *op = EOS; + + return (execute); +} + + +/* SEARCH_HISTORY -- Search for the occurrence of the given string in the + * history buffer, leaving the corresponding command in the output buffer + * if it matches the pattern. Return the number of directive characters used. + * The "repeat last command" directive "^" is a special case: the null string + * matches anything. + */ +int +search_history ( + char *directive, + char *new_command_block +) +{ + register char *ip, *op, *p; + char pattern[SZ_FNAME]; + int match_only_at_bol=1, record, patlen; + + ip = directive + 1; /* skip the '^' */ + + if (*ip == '\\' && *(ip+1) == MATCH_ANYWHERE) + ip++; + else if (*ip == MATCH_ANYWHERE) { + ip++; + match_only_at_bol = 0; + } + + /* Extract pattern, delimited by whitespace, EOS, ?, or ":p", + * depending on whether we have ?? delimiters. + */ + patlen = strlen (NO_EXECUTE); + for (op=pattern; (*op = *ip) != EOS; op++, ip++) + if (match_only_at_bol) { + if (isspace (*ip)) + break; + else if (strncmp (ip, NO_EXECUTE, patlen) == 0) + break; + } else if (*ip == '\\' && *(ip+1) == MATCH_ANYWHERE) { + *op = *++ip; + } else if (*ip == MATCH_ANYWHERE) { + ip++; + break; + } + *op++ = EOS; + + /* Search backwards in history buffer until command is found + * which matches the pattern. The null pattern matches anything. + */ + patlen = strlen (pattern); + record = 1; + + while (get_history (record++, new_command_block, SZ_CMDBLK) != ERR) { + if (patlen == 0) { + break; + } else if (match_only_at_bol) { + if (strncmp (new_command_block, pattern, patlen) == 0) + break; + } else { + for (p=new_command_block; *p != EOS; p++) { + if (*p == *pattern && strncmp(p,pattern,patlen) == 0) + break; + } + if (*p != EOS) + break; + } + } + + if (strlen (new_command_block) == 0) + cl_error (E_UERR, "Event not found"); + + return (ip - directive); +} + + +/* STREDIT -- Edit string "in_text" according to the editing directive + * string given as the first argument, placing the edited string in the + * buffer "out_text". Return the number of characters used in the + * edit directive string. + * This is actually a general purpose string editor. For the history code, + * the edit directives are "^^", "^str", and "^?str". The directive "^^" + * is actually an edit directive wherein the match and substitute strings + * are both null, causing the last command to be repeated without change. + * The first character in the edit directive is taken to be the edit + * metacharacter (i.e., "^", "/", etc.). + */ +int +stredit ( + char *edit_directive, /* e.g., "^str1^str2^" */ + char *in_text, /* text to be edited */ + char *out_text /* buffer for output text */ +) +{ + register char *ip, *op, *pp; + char metacharacter; + char pattern[SZ_LINE+1], text[SZ_LINE+1]; + int replace_all_occurrences=0; + int patlen, len_directive, nmatches; + + /* Extract pattern and substitution strings. The history metacharacter + * may be included in a string if escaped. Otherwise, we leave + * escape sequences completely alone. + */ + ip = edit_directive; + metacharacter = *ip++; + + for (op=pattern; (*op = *ip) != EOS; ip++, op++) + if (*ip == '\\' && *(ip+1) == metacharacter) + *op = *++ip; + else if (*ip == metacharacter) { + ip++; + break; + } + *op = EOS; + patlen = strlen (pattern); + + /* If the directive is "^^", we do not permit a substitution string + * so that the directive may be used to append text to the previous + * command. We interpret the sequences "^\n" and "^\t" as newline + * and tab, respectively. + */ + if (patlen > 0) { + for (op=text; (*op = *ip) != EOS; ip++, op++) + if ((*ip == metacharacter && *(ip+1) == '\\') && + (*(ip+2) == 'n' || *(ip+2) == 't')) { + ip += 2; + *op = (*ip == 'n') ? '\n' : '\t'; + } else if (*ip == '\\' && *(ip+1) == metacharacter) { + *op = *++ip; + } else if (*op == '\n' || *op == metacharacter) { + ip++; + break; + } + *op = EOS; + if (*ip == MATCH_ALL) { + replace_all_occurrences = 1; + ip++; + } + } else + *text = EOS; + + /* All done processing edit directive; get nchars processed. */ + len_directive = ip - edit_directive; + + + /* Edit the command, unless directive is "^^" (null pattern). */ + nmatches = 0; + + for (ip=in_text, op=out_text; *ip != EOS; ) { + /* Advance to next match */ + for (pp=pattern; (*op = *ip) != EOS; op++, ip++) + if (*ip == *pp && strncmp (ip, pattern, patlen) == 0) { + nmatches++; + break; + } + if (patlen == 0) + break; + else if (nmatches == 0) + cl_error (E_UERR, "No match"); + + /* Copy replacement string, advance input pointer past the + * matched string, if we have a match. + */ + if (*ip == *pp) { + for (pp=text; (*op = *pp++) != EOS; op++) + ; + ip += patlen; + } + + if (!replace_all_occurrences) { + while ((*op = *ip++) != EOS) + op++; + break; + } + } + + *op = EOS; + return (len_directive); +} + + +/* EXPAND_HISTORY_MACROS -- Copy the input string to the output string, + * replacing all occurrences of "^$" by the final argument the last command, + * all occurrences of "^^" by the first argument of the last command, and + * all occurrences of "^*" by the full argument list of the last command. + * If the command block contains more than one line, we assume that the + * argument list spans several lines. If this is not true, the expansion + * will not be what the user wanted (but then they probably screwed up). + * The function returns true if any macros were expanded. + */ +int +expand_history_macros ( + char *in_text, + char *out_text +) +{ + register char *ip, *op, *ap; + char cmdblk[SZ_CMDBLK+1], *argp[100]; + int nargs, nrep, argno, have_arg_strings=0; + char *index(); + + /* Copy the command text. Fetch argument strings from history only + * if a history macro is found. Otherwise the copy is very fast. + */ + for (ip=in_text, op=out_text; (*op = *ip) != EOS; ip++, op++) { + if (*ip == '"') { /* span literal strings */ + while (1) { + *op++ = *ip++; + if (*ip == '"' && *(ip+1) != '"') { + *op = *ip; + break; + } + } + continue; + } else if (*ip == HISTCHAR) { + if (ip > in_text && *(ip-1) == '\\') { + *(--op) = HISTCHAR; /* \^ */ + continue; + } else if (!isdigit(*(ip+1)) && index(ARGCHARS,*(ip+1)) == NULL) + continue; + + /* Parse the argument list of the previous command if have not + * already done so. + */ + if (!have_arg_strings++) { + if (get_history (1, cmdblk, SZ_CMDBLK) == ERR) + cl_error (E_UERR, "Nothing in history buffer"); + nargs = get_arglist (cmdblk, argp); + } + + /* Set up the substitution. + */ + switch (*(ip+1)) { + case FIRSTARG: + argno = 1; + nrep = 1; + break; + case LASTARG: + argno = nargs; + nrep = 1; + break; + case ALLARGS: + argno = 1; + nrep = nargs; + break; + default: + argno = *(ip+1) - '0'; + nrep = 1; + break; + } + + /* Copy the arguments to the output command, overwriting the + * history metacharacter (*op). + */ + while (--nrep >= 0 && argno <= nargs) { + for (ap=argp[argno++]; (*op = *ap++); op++) + ; + if (nrep > 0) + *op++ = ' '; + } + + --op; /* leave pointing at last char output */ + ip++; /* skip the macro type metacharacter */ + } + } + + return (have_arg_strings > 0); +} + + +/* GET_ARGLIST -- Fetch the last command line and return an array of + * pointers to the whitespace delimited argument strings. If parsing a + * full command line, argument "zero" is the task name (the first token), + * and argp[1] the first real argument. The number of arguments + * (excluding the task name) is returned as the function value. + * + * NOTE -- The input argument list is modified (the argp[i] point into it). + * NOTE -- This procedure is used elsewhere in the CL to parse argument lists. + */ +int +get_arglist ( + char *cmdblk, /* buffer to store argument list in */ + char *argp[] /* receives argument pointers */ +) +{ + register char *cp; + register int nargs; + + for (cp=cmdblk, nargs=0; *cp != EOS; ) { + /* Advance to next token; convert newline to EOS. */ + while (*cp == ' ' || *cp == '\t') + cp++; + if (*cp == '\n' || *cp == EOS) { + *cp = EOS; + break; + } + + /* Set argument pointer and bump argument count. */ + argp[nargs++] = cp; + + /* Mark the end of the token. */ + while (*cp && !isspace (*cp)) + cp++; + if (*cp == ' ' || *cp == '\t') + *cp++ = EOS; + } + + return (nargs - 1); +} + + +/* PUT_HISTORY -- Add a new record to the history buffer. Record cannot + * be larger than SZ_CMDBLK, which must be smaller than SZ_HISTBUF. Copy + * chars into histbuf in circular buffer fashion, overwriting old history + * data. EOS delimits records in the history buffer. + */ +void +put_history (char *command) +{ + register char *ip, *op, *otop; + + /* Make sure there is exactly one newline at the end of the command. */ + for (ip = command + strlen(command) - 1; ip >= command; --ip) + if (!isspace (*ip)) + break; + *++ip = '\n'; + *++ip = EOS; + + otop = histbuf + SZ_HISTBUF; + ip = command; + op = op_hist; + + do { + *op++ = *ip; + if (op >= otop) { + op = histbuf; + histbuf_full++; + } + } while (*ip++ != EOS); + + op_hist = op; + histnum++; +} + + +/* GET_HISTORY -- Fetch the indicated command from the history buffer, + * returning OK if found, ERR otherwise. + */ +int +get_history ( + int record, + char *command, + int maxch +) +{ + char *recptr; + char *find_history(); + + if ((recptr = find_history (record)) == NULL) { + *command = EOS; + return (ERR); + } else { + fetch_history (recptr, command, maxch); + return (OK); + } +} + + +/* FETCH_HISTORY -- Extract the command pointed to by the first argument + * from the history buffer into the user buffer (the latter is a nice, + * well behaved linear rather than circular buffer). + */ +void +fetch_history ( + char *recptr, + char *command, + int maxch +) +{ + register char *ip, *op, *itop; + register int n; + + itop = histbuf + SZ_HISTBUF; + ip = recptr; + op = command; + n = ((maxch < SZ_HISTBUF) ? maxch : SZ_HISTBUF) - 1; + + while (--n >= 0 && (*op = *ip++) != EOS) { + *op++; + if (ip >= itop) + ip = histbuf; + } + + *op = EOS; +} + + +/* FIND_HISTORY -- Locate the indicated command record in the history buffer, + * returning a pointer to the first char or NULL. Commands are referenced + * by number, where 1 is the most recent command, 2 the one before that, and + * so on. We are done when we search so far back that we reach the location + * op_hist. To speed up linear searches of the history buffer, we keep track + * of where we are on successive calls, provided the buffer has not been + * written into between calls. We can detect this by saving a copy of + * op_hist in a static variable between calls. + */ +char * +find_history (int record) +{ + register char *ip, *op, *bufptr; + static int current_record = 0; + static char *recptr, *old_ophist = NULL; + + if (histnum == 0 || record <= 0) + return (NULL); + + /* We only search backwards into history: if desired record is + * more recent than the "current record", or if the buffer has + * been written into, reset and search from the beginning. The + * "current record" is the record pointed to by recptr. + */ + if (old_ophist != op_hist || record < current_record) { + current_record = 0; + old_ophist = recptr = op_hist; + } + + ip = recptr; /* start here */ + op = op_hist; /* not found if get here */ + bufptr = histbuf; /* wrap around if get here */ + + /* Search backwards into history for the record, starting from the + * current position (initially record number "0", the next record to + * be filled). Each time through the loop, set recptr for the new + * "current record". + */ + while (current_record < record) { + if (--ip < bufptr) { /* backup to EOS */ + if (!histbuf_full) + return (NULL); + ip = histbuf + SZ_HISTBUF - 1; + } + do { + if (--ip < bufptr) { + /* Initially, before the buffer fill up, there is no EOS + * preceeding the first record. + */ + if (!histbuf_full) + break; + ip = histbuf + SZ_HISTBUF - 1; + } + if (ip == op) + return (NULL); /* cannot find record */ + } while (*ip != EOS); + + /* Advance to first char of next record */ + if (++ip >= histbuf + SZ_HISTBUF) + ip = bufptr; + recptr = ip; + current_record++; + } + history_number = current_record; /* save this globally */ + return (recptr); +} + + +/* SHOW_HISTORY -- Print the contents of the history buffer on the output + * stream, preceeding each command block with a 3 digit command number. + * Show at most min (max_commands, MAX_SHOWHIST) command blocks. + */ +void +show_history ( + FILE *fp, + int max_commands +) +{ + char *recptr[MAX_SHOWHIST]; + char cmdblk[SZ_CMDBLK+1]; + int record; + char *find_history(); + + /* Flush the "history" command so that it shows up in the history. */ + yy_startblock (LOG); + + /* Determine the number of records to show. */ + for (record=0; record < MAX_SHOWHIST; record++) + if ((recptr[record] = find_history (record+1)) == NULL) + break; + if (max_commands > 0) + record = (record < max_commands) ? record : max_commands; + + /* Print the records with the 3 digit record number plus a blank + * on the first line and 4 blanks at the beginning of each successive + * line of the block. + */ + while (record > 0) { + fprintf (fp, "%3d ", (histnum - (--record)) % 1000); + fetch_history (recptr[record], cmdblk, SZ_CMDBLK+1); + print_command (fp, cmdblk, "", " "); + fflush (fp); + } +} + + +/* PPROMPT -- Print prompt as first two chars of prompt string plus "> ", i.e., + * "pk> ". If null prompt string (NOCLOSURE), print the continuation prompt + * ">>> ". Also print, before the prompt, all ltasks in current package + * if menus() are enabled and a new package has been invoked. + */ +void +pprompt ( + register char *string +) +{ + static struct package *lastpack = NULL; + + if (menus() && curpack != lastpack) { + listhelp (curpack, NO); + lastpack = curpack; + } + + printf ("%2.2s", string); + printf ("> "); + fflush (stdout); +} + + +/* PUT_LOGFILE -- Put a command into the logfile, if logging is enabled. + * Otherwise check if the logfile is open and close it, in case user has + * just turned logging off. If the "share_logfile" switch is set the logfile + * is opened and closed each time a record is appended to the file, allowing + * other processes to access the same file. + */ +void +put_logfile (char *command) +{ + FILE *fp; + + if (keeplog()) { + if (logfp == NULL) + if (open_logfile (logfile()) == ERR) + /* Do not abort by calling cl_error(). We could be a + * background job accessing a shared logfile. Also, we + * want to avoid error recursion when logging an error. + */ + return; + + if (share_logfile) { + if ((fp = fopen (logfile(), "a"))) { + print_command (fp, command, "", ""); + fclose (fp); + } + } else + print_command (logfp, command, "", ""); + + } else if (logfp != NULL) + close_logfile (logfile()); +} + + +/* OPEN_LOGFILE -- Open the named command logging file for appending, + * timestamp new session. The logfile grows without bounds unless the + * user deletes it or starts a new one. + */ +int +open_logfile (char *fname) +{ + if (logfp != NULL) + close_logfile (fname); + + if ((logfp = fopen (fname, "a")) == NULL) { + eprintf ("cannot open logfile\n"); + return (ERR); + } + + if (!(firstask->t_flags & T_BATCH)) + fprintf (logfp, "\n# LOGIN %s\n", today()); + + if (share_logfile) + fclose (logfp); + + return (OK); +} + + +/* CLOSE_LOGFILE -- Print termination message and close logfile. + */ +void +close_logfile (char *fname) +{ + register FILE *fp; + + if (logfp != NULL) { + if (share_logfile) { + if ((fp = fopen (fname, "a")) == NULL) { + eprintf ("cannot open logfile\n"); + return; + } + } else + fp = logfp; + + if (!(firstask->t_flags & T_BATCH)) + fprintf (fp, "# Logout %s\n", today()); + + fclose (fp); + logfp = NULL; + } +} + + +/* RESET_LOGFILE -- The name of the logfile has been reset by the user. + * Close and reopen the logfile, but only if share_logfile option is off. + */ +void +reset_logfile (void) +{ + if (!share_logfile) { + close_logfile (""); + open_logfile (logfile()); + } +} + + +/* PRINT_COMMAND -- Print a (possibly multiline) command to the same left + * margin as when it was entered. + */ +void +print_command ( + register FILE *fp, + char *command, + char *marg1, /* margin strings of first and subseq. cmds */ + char *marg2 +) +{ + register char *ip; + + fprintf (fp, marg1); + for (ip=command; *ip != EOS; ip++) { + fputc (*ip, fp); + if (*ip == '\n' && *(ip+1) != EOS) + fprintf (fp, marg2); + } +} + + +/* TODAY -- Get todays date as a string, for datestamping the logfile. + */ +char * +today (void) +{ + static char datebuf[64]; + + c_cnvtime (c_clktime(0L), datebuf, 64); + return (datebuf); +} + + +/* WHAT_RECORD -- Return the record number of the last edited history + */ +int +what_record (void) +{ + return (history_number); +} + + +/* PUTLOG -- Format and write a message to the logfile. This is called by + * the putlog builtin (clputlog() in builtin.c) and in some places in the + * CL (e.g., exec.c). + */ +void +putlog ( + struct task *tp, /* pointer to task or NULL */ + char *usermsg +) +{ + register char *ip, *op, *otop; + register int n; + char msg[SZ_LOGBUF], job[5]; + char *pkg, *tname, *today(); + extern int bkgno; /* job number if bkg job */ + + if (!keeplog()) + return; + + /* If background job, format job number, but only if background + * logging is enabled. + */ + if (firstask->t_flags & T_BATCH) { + if (log_background()) + sprintf (job, "[%d] ", bkgno); + else + return; + } else + job[0] = EOS; + + /* If a valid task pointer is given, get the package and task name. + * Otherwise, assume it's an internal (cl) logging message. + */ + if (tp) { + pkg = tp->t_ltp->lt_pkp->pk_name; + tname = tp->t_ltp->lt_lname; + } else { + pkg = "cl"; + tname = ""; + } + + /* Format the message. Only use time, no day and date. Break long + * messages into several lines. + */ + sprintf (msg, "# %8.8s %s%s%s %s- ", + (today() + 4), pkg, (tp ? "." : ""), tname, job); + otop = &msg[SZ_LOGBUF]; + for (op=msg, n=0; *op && op < otop; op++) + n++; + for (ip=usermsg; (*op++ = *ip++) && op < otop; n++) + if (n + 2 >= MAXCOL) { + *op++ = '\\'; + *op++ = '\n'; + n = 0; + } + *(op-1) = '\n'; + *op = EOS; + + put_logfile (msg); +} diff --git a/pkg/cl/lex.com b/pkg/cl/lex.com new file mode 100644 index 00000000..32c198cd --- /dev/null +++ b/pkg/cl/lex.com @@ -0,0 +1,12 @@ +$! Fix the lexyy.c file (see lex.sed) [VMS] +$! +$ open/write fp lex_fix.com +$ write fp "$ edit/edt/nocommand lexyy.c" +$ write fp "sub/getc(yyin)/yy_getc(yyin)/w" +$ write fp "sub/yylex/lex_yylex/w" +$ write fp "sub/YYLMAX 200/YYLMAX 2048/w" +$ write fp "exit" +$ write fp "$ exit" +$ close fp +$ @lex_fix.com +$ delete lex_fix.com;* diff --git a/pkg/cl/lex.sed b/pkg/cl/lex.sed new file mode 100644 index 00000000..1b1a1377 --- /dev/null +++ b/pkg/cl/lex.sed @@ -0,0 +1,4 @@ +s/getc(yyin)/yy_getc(yyin)/ +s/yylex/lex_yylex/ +s/YYLMAX 200/YYLMAX 2048/ +1d diff --git a/pkg/cl/lexicon.c b/pkg/cl/lexicon.c new file mode 100644 index 00000000..5a600d01 --- /dev/null +++ b/pkg/cl/lexicon.c @@ -0,0 +1,655 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_ctype +#define import_xnames +#define import_lexnum +#include + +#include "proto.h" + + +extern int cldebug; + +/* + * NOTE: This file is #included in the parser and inherits the parser global + * declarations. + */ + +#define LEXDEBUG 1 +#define newtoken (yyleng==0) + +int _lexmodes; /* nonzero enables mode switching */ +int lexdebug=0; /* debug lexical analyzer */ +int lexcol=0; /* nchars since \n or ; */ +int pbtoken; /* push back token */ +int newarg; /* whitespace argument delimiter seen */ +int lhs; /* "left hand side" switch for [] */ + +/* YYLEX -- Return the next token from the input stream. Two separate lexical + * analyzers are provided, the "command mode" lexical analyzer for interactive + * command entry, and the "compute mode" analyzer for more sophisticated + * applications. The nesting level of parentheses and braces is used to switch + * between the two modes. When the paren level is nonzero compute mode is in + * effect. Mode switching may be defeated by setting the external variable + * _lexmodes to zero. A single parser accepts input from both lexical + * analyzers. + */ +yylex() +{ + register int token; + + if (_lexmodes && parenlevel == 0 && bracelevel < PBRACE) { + while (!(token = lexicon())) + if (yywrap()) + break; + } else + token = lex_yylex(); + + if (!lexdebug) + return (token); + +#if LEXDEBUG + switch (token) { + case Y_CONSTANT: + eprintf ("CONSTANT "); + fprop (stderr, reference (operand, yylval)); + eprintf ("\n"); + break; + case Y_IDENT: + eprintf ("IDENT "); + fprop (stderr, reference (operand, yylval)); + eprintf ("\n"); + break; + case Y_OSESC: + eprintf ("Y_OSESC "); + fprop (stderr, reference (operand, yylval)); + eprintf ("\n"); + break; + case Y_APPEND: + eprintf ("Y_APPEND\n"); + break; + case Y_ALLAPPEND: + eprintf ("Y_ALLAPPEND\n"); + break; + case Y_ALLREDIR: + eprintf ("Y_ALLREDIR\n"); + break; + case Y_GSREDIR: + eprintf ("Y_GSREDIR\n"); + break; + case Y_ALLPIPE: + eprintf ("Y_ALLPIPE\n"); + break; + case Y_NEWLINE: + eprintf ("NEWLINE\n"); + break; + default: + eprintf ("`%c'\n", token); + break; + } +#endif + + return (token); +} + + +/* LEXICON -- Simple "conversational mode" lexical analyser. Lexical analysis + * in the CL is carried out by a dual mode lexical analyser. In conversational + * mode there are few tokens and few special characters; arguments are + * delimited by whitespace and may contain nonalphanumeric characters. Few + * strings have to be quoted. In computational mode the arithmetic operators + * are recognized and arguments must be delimited by commas. Computational + * mode is in effect whenever the parenlevel is nonzero. + * + * The two modes are implemented with two separate lexical analyzers. Gettok + * implements conversational mode, while computational mode is implemented with + * a LEX finite state automaton. Gettok recognizes the following special chars: + * + * [ \t] argument delimiter + * ["'] string + * \n newline + * \ single character escape + * ! os escape + * # comment + * & spawn background job + * ( lparen + * + plus (switch) + * - minus (switch) + * ; eost + * = equals + * += add and set + * -= subtract and set + * *= multiply and set + * /= divide and set + * < redirin + * > redir + * >& allredir + * >> append + * >>& allappend + * >(G|I|P|)+ graphics stream redirection + * { lbrace + * | pipe + * |& allpipe + * } rbrace + * [ beginning of index list + * ] end of index list + * + * The history metacharacter ^ is processed before input is passed to the + * lexical analyser. Any sequence of nonwhite characters that does not form + * one of the recognized tokens is returned as a string. + */ +lexicon() +{ + char *bkgerr = "ERROR: cannot submit background job inside {}\n"; + register int ch, cch; + register int token; + int stringtok, identifier, setlevel; + int clswitch; + char *op, *index(); + + /* Return pushed back token if any. + */ + if (pbtoken) { + token = pbtoken; + pbtoken = 0; + return (token); + } + + /* Skip leading whitespace. If whitespace is seen and we are in an + * argument list (according to the parser) set flag to output the + * comma argument delimiter if the next token begins an argument. + * If whitespace or = is seen (except whitespace at the beginning of + * a command) then set LHS to false, turning [] off as conversational + * mode metacharacters (they will be automatically turned on when + * compute mode is entered in an expression). + */ + while (ch = input()) + if (ch == ' ' || ch == '\t') { +space: if (lexcol > 0) + lhs = 0; + if (inarglist) + newarg++; + } else if (ch == '\\') { + if ((ch = input()) != '\n') { + unput (ch); + break; + } else + goto space; + } else + break; + + + /* Start new token. + */ + if (ch) { + unput (ch); + yyleng = 0; + if (!inarglist) + newarg = 0; + } else + return (0); + + + /* Identify and accumulate next token. Simple tokens are returned as + * integer constants, more complex tokens as operand structures in + * yylval. + */ + while (ch = input()) { + lexcol++; + + switch (ch) { + case '&': + /* An ampersand triggers bkg execution in command mode, unless + * it occurs in a token such as >& or >>&, in which case we + * never get here. + */ + if (!newtoken) { + unput (ch); + goto tokout_; + } else { + while (ch = input()) { + if (ch == ' ' || ch == '\t') + continue; + else { + char bkgmsg[SZ_LINE+1]; + int n = SZ_LINE; + + op = bkgmsg; + unput (ch); + if (bracelevel) { + eprintf (bkgerr); + return ('#'); + } + + while (--n >= 0 && (*op = input()) != '\n') + op++; + *op = EOS; + bkg_init (bkgmsg); + return (Y_NEWLINE); + } + } + return (0); + } + + case ';': + case '\n': + lexcol = 0; + lhs = 1; + goto etok_; + + case '\t': + case ' ': + if (lexcol > 0) + lhs = 0; + goto etok_; + + case '[': + case ']': + /* [] are recognized as command mode metacharacters only + * on the left hand side of an assignment statement. + */ + if (!lhs) + goto deposit_; + /* Fall through */ + + case '{': + case '}': + /* We want to distinguish here between the use of {} for + * the set selection operator in template strings, and the + * conventional compound statement operator. The distinction + * is that { is recognized as a token only if occurs at the + * beginning of a token, and } is recognized as a separate + * token when inside a token only if it matches a { in the + * same token. Hence, alpha{xxx} is a single token in command + * mode, whereas {xxx} is 3 tokens, the same as { xxx }, + * and xxx} is the same as xxx }. Usage is completely + * unambiguous if the { or } is preceded by a space. + */ + if (newtoken) + return (ch); + if (stringtok) { + if (ch == '{') + setlevel++; + else if (setlevel == 0) + goto etok_; /* } does not match { */ + else + --setlevel; + goto deposit_; + } + /* fall through */ + + case '=': +etok_: if (!newtoken) { + unput (ch); + goto tokout_; + } else if (ch == '\n') { + return (Y_NEWLINE); + } else if (ch == '=') { + token = ch; + lhs = 0; + goto eatwhite_; + } else + return (ch); + + case '?': + /* ?, ?? menu commands, recognized only at beginning of stmt */ + if (lexcol > 1) { + goto deposit_; + } else if (ch = input()) { + if (ch == '?') + return (crackident ("??")); + else { + unput (ch); + return (crackident ("?")); + } + } else + return (0); + + case '+': + case '-': + /* Plus and minus are recognized as the switch operators for + * boolean parameters only if encountered while accumulating + * a token and if followed by an argument delimiter, i.e., + * space, tab, newline, or semicolon. If found at the beginning + * of a token they are returned as a separate token and will be + * interpreted by the parser as unary plus or minus. + */ + if (newtoken) { + if (newarg) { + cch = input(); + if (cch == 0) + return (0); + unput (cch); + + if (ch == '-' && isdigit (cch)) { + unput (ch); + newarg = 0; + return (','); + } else { + /* Not number; treat +- as a string char. + */ + goto deposit_; + } + + } else { + cch = input(); + if (cch == 0) + return (0); + + if (cch == '=') { + if (ch == '+') + return (YOP_AOADD); + else + return (YOP_AOSUB); + } else if (isdigit (cch)) { + unput (cch); + return (ch); + } else { + unput (cch); + goto deposit_; + } + } + + } else if (cch = input()) { + clswitch = (isspace (cch) || cch == ';'); + if (cch == '=') { + unput(cch); + unput (ch); + goto tokout_; + } + unput (cch); + if (clswitch) { + pbtoken = ch; + goto tokout_; + } else + goto deposit_; + } else + return (0); + + case '"': + case '\'': + if (!newtoken) { + unput (ch); + goto tokout_; + } else if (newarg) { + unput (ch); + newarg = 0; + return (','); + } else { + traverse (ch); + yylval = addconst (yytext, OT_STRING); + return (Y_CONSTANT); + } + + case '\\': + if (ch = input()) { + if (ch == '\n') + continue; + else if (index ("&;=+-\"'\\#><()|", ch) != NULL) + goto deposit_; /* put ch in string */ + else + goto escape_; /* put \ch in string */ + } else + return (0); + + case '!': + /* OS escape is only recognized when the ! occurs as the first + * token in a statement. + */ + if (lexcol > 1) + goto deposit_; + + /* Accumulate command. Newline may be escaped to enter a long + * command, but all other escapes are passed on unmodified. + */ + while ((ch = input()) && ch != '\n') { + if (ch == '\\') + if (ch = input()) { + if (ch == '\n') + continue; + else + yytext[yyleng++] = '\\'; + } else + break; + yytext[yyleng++] = ch; + } + if (ch) + unput (ch); + + yytext[yyleng] = '\0'; + yylval = addconst (yytext, OT_STRING); + return (Y_OSESC); + + case '#': + /* Discard the comment line. */ + while ((ch = input()) && ch != '\n') + ; + if (ch) { + unput (ch); + continue; + } else + return (0); + + case '>': + case '<': + case '(': + /* These characters are alike in that they all begin a new + * argument when found in an argument list. + */ + if (!newtoken) { + unput (ch); + goto tokout_; + } else if (newarg) { + unput (ch); + newarg = 0; + return (','); + } else if (ch == '<') { + token = ch; + goto eatwhite_; + + } else if (ch == '>') { + ch = input(); + if (ch == 0) { + return ('>'); + + } else if (ch == '>') { + ch = input(); + if (ch == 0) { + return (Y_APPEND); + } else if (ch == 'G' || ch == 'I' || ch == 'P') { + op = yytext; + *op++ = '>'; + *op++ = '>'; + *op++ = ch; + goto gsredir_; + } else if (ch == '&') { + token = Y_ALLAPPEND; + goto eatwhite_; + } else { + unput (ch); + token = Y_APPEND; + goto eatwhite_; + } + + } else if (ch == 'G' || ch == 'I' || ch == 'P') { + /* Graphics stream redirection. + */ + op = yytext; + *op++ = '>'; + *op++ = ch; +gsredir_: + ch = input(); + while (ch == 'G' || ch == 'I' || ch == 'P') { + *op++ = ch; + ch = input(); + } + unput (ch); + *op = EOS; + + yylval = addconst (yytext, OT_STRING); + token = Y_GSREDIR; + goto eatwhite_; + + } else if (ch == '&') { + token = Y_ALLREDIR; + goto eatwhite_; + } else { + unput (ch); + token = '>'; + goto eatwhite_; + } + + } else + return ('('); + + case '|': + if (!newtoken) { + unput (ch); + goto tokout_; + } else if (ch = input()) { + if (ch == '&') + return (Y_ALLPIPE); + else { + unput (ch); + return ('|'); + } + } else + return (0); + + case '*': + case '/': + cch = input(); + if (cch == 0) + return (0); + + if (newtoken) { + if (cch == '=') + return ((ch=='*') ? YOP_AOMUL:YOP_AODIV); + else { + unput (cch); + goto deposit_; + } + } else { + if (cch == '=') { + unput (cch); + unput (ch); + goto tokout_; + } else { + unput (cch); + goto deposit_; + } + } + + /* The following cases are included to force the compiler + * to compile the case as an ASCII jump table. + */ + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + /* fall through to default */ + + default: + goto deposit_; +escape_: + /* Deposit a character preceded by the escape character. + */ + if (!newarg) { + unput (ch); + ch = '\\'; + } +deposit_: + /* If the last token returned was a string argument and we + * are starting a second, a delimiter token must be returned + * to delimit the two arguments. Check for chars not legal + * in an identifier so that we can know whether to return + * CONSTANT or call crackident() which returns IDENT if not + * a reserved keyword. + */ + if (newtoken) { + identifier = 1; + stringtok = 1; + setlevel = 0; + if (newarg) { + unput (ch); + newarg = 0; + return (','); + } + } + + yytext[yyleng++] = ch; + if (ch == '\\') + yytext[yyleng++] = ch = input(); + else if (!(isalnum(ch) || ch == '_' || ch == '$' || ch == '.')) + identifier = 0; + } + } + +tokout_: + yytext[yyleng] = '\0'; + + if (isdigit (yytext[0]) || yytext[0] == '.' && isdigit (yytext[1])) { + int token, toklen; + + token = c_lexnum (yytext, &toklen); + if (token != LEX_NONNUM && toklen == yyleng) { + switch (token) { + case LEX_REAL: + yylval = addconst (yytext, OT_REAL); + break; + default: + yylval = addconst (yytext, OT_INT); + break; + } + return (Y_CONSTANT); + } + } + + if (identifier) + return (crackident (yytext)); + else { + yylval = addconst (yytext, OT_STRING); + return (Y_CONSTANT); + } + +eatwhite_: + /* Control transfers here after a token has been identified which is + * followed by an associated argument (e.g. > file or < file). Our + * function is to discard any whitespace following the current token + * in order to make whitespace optional in the input at this point. + * This makes "> file" (for example) equivalent to ">file". + */ + newarg = 0; + while ((ch = input()) && (ch == ' ' || ch == '\t')) + ; + if (ch) { + unput (ch); + return (token); + } else + return (0); +} + + +/* LEXINIT -- Initialize the internal state variables of the lexical analyzer, + * e.g. when processing is interrupted by an interrupt. + */ +lexinit() +{ + if (lexmodes() && !lex_cpumodeset (currentask->t_in)) { + lexcol = 0; + newarg = 0; + pbtoken = 0; + lhs = 1; + _lexmodes = 1; + } else + _lexmodes = 0; +} diff --git a/pkg/cl/lexyy.c b/pkg/cl/lexyy.c new file mode 100644 index 00000000..4f1bdb1b --- /dev/null +++ b/pkg/cl/lexyy.c @@ -0,0 +1,897 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +# define U(x) x +# define NLSTATE yyprevious=YYNEWLINE +# define BEGIN yybgin = yysvec + 1 + +# define INITIAL 0 +# define YYLERR yysvec +# define YYSTATE (yyestate-yysvec-1) +# define YYOPTIM 1 +# define YYLMAX BUFSIZ +# define output(c) putc(c,yyout) +# define input() (((yytchar=yysptr>yysbuf?U(*--yysptr):yy_getc(yyin))==10?(yylineno++,yytchar):yytchar)==EOF?0:yytchar) +# define unput(c) {yytchar= (c);if(yytchar=='\n')yylineno--;*yysptr++=yytchar;} +# define yymore() (yymorfg=1) +# define ECHO fprintf(yyout, "%s",yytext) +# define REJECT { nstr = yyreject(); goto yyfussy;} +int yyleng; extern char yytext[]; +int yymorfg; +extern char *yysptr, yysbuf[]; +int yytchar; +FILE *yyin = {stdin}, *yyout = {stdout}; +extern int yylineno; +struct yysvf { + struct yywork *yystoff; + struct yysvf *yyother; + int *yystops;}; +struct yysvf *yyestate; +extern struct yysvf yysvec[], *yybgin; +# define YYNEWLINE 10 +lex_yylex(){ +int nstr; extern int yyprevious; +while((nstr = yylook()) >= 0) +yyfussy: switch(nstr){ +case 0: +if(yywrap()) return(0); break; +case 1: + /* groups of blanks and tabs, while significant as delimiters, + * are otherwise ignored. + */ ; +break; +case 2: +{ /* trailing ',' implies continuation */ + return (','); + } +break; +case 3: +{ /* trailing '\' completely absorbed */ + } +break; +case 4: +{ + /* Host os command escape. Remove everything up through + * '!'. Let clsystem decide what to do with null cmd. + * Must precede the "!" YOP_NOT spec in this file. + */ + register char *cp; + for (cp = yytext; *cp++ != '!'; ) + ; + yylval = addconst (cp, OT_STRING); + return (Y_OSESC); + } +break; +case 5: + return (Y_ALLPIPE); +break; +case 6: + return (Y_APPEND); +break; +case 7: + return (Y_ALLAPPEND); +break; +case 8: + return (Y_ALLREDIR); +break; +case 9: +{ + yylval = addconst (yytext, OT_STRING); + return (Y_GSREDIR); + } +break; +case 10: + return (YOP_LE); +break; +case 11: + return (YOP_GE); +break; +case 12: + return (YOP_EQ); +break; +case 13: + return (YOP_NE); +break; +case 14: + return (YOP_POW); +break; +case 15: + return (YOP_OR); +break; +case 16: + return (YOP_AND); +break; +case 17: + return (YOP_NOT); +break; +case 18: + return (YOP_AOADD); +break; +case 19: + return (YOP_AOSUB); +break; +case 20: + return (YOP_AOMUL); +break; +case 21: + return (YOP_AODIV); +break; +case 22: + return (YOP_AOCAT); +break; +case 23: + return (YOP_CONCAT); +break; +case 24: + { if (dobrace) { + dobrace = NO; + return (*yytext); + } else { + dobrace = YES; + unput (*yytext); + return (';'); + } + } +break; +case 25: + return (*yytext); +break; +case 26: + return (*yytext); +break; +case 27: + return (crackident (yytext)); +break; +case 28: + return (crackident (yytext)); +break; +case 29: + { extern bracelevel; + if (bracelevel) { + eprintf ("ERROR: background not allowed within statement block\n"); + return ('#'); + } else { + yyleng = 0; + while ((yytext[yyleng]=input()) != '\n') + yyleng++; + yytext[yyleng] = '\0'; + bkg_init (yytext); + return (Y_NEWLINE); + } + } +break; +case 30: +{ + /* crackident() sets yylval and returns token value. + */ + return (crackident (yytext)); + } +break; +case 31: +{ + /* must precede OT_REAL as integers also match there */ + yylval = addconst (yytext, OT_INT); + return (Y_CONSTANT); + } +break; +case 32: +{ + yylval = addconst (yytext, OT_REAL); + return (Y_CONSTANT); + } +break; +case 33: +{ + /* sexagesimal format */ + yylval = addconst (yytext, OT_REAL); + return (Y_CONSTANT); + } +break; +case 34: +{ /* Quoted string. call traverse() to read the + * string into yytext. + */ + traverse (*yytext); + yylval = addconst (yytext, OT_STRING); + return (Y_CONSTANT); + } +break; +case 35: + return (Y_NEWLINE); +break; +case 36: +{ /* Ignore a comment. */ + while (input() != '\n') + ; + unput ('\n'); + } +break; +case 37: + return (*yytext); +break; +case -1: +break; +default: +fprintf(yyout,"bad switch yylook %d",nstr); +} return(0); } +/* end of lex_yylex */ + +#include "errs.h" + +/* See gram.c for the various support functions, such as addconst() + * and crackident(). Traverse is included here since it directly + * references input, unput, yytext, etc. + */ + +/* TRAVERSE -- Called by the lexical analyzer when a quoted string has + * been recognized. Characters are input and deposited in yytext (the + * lexical analyzer token buffer) until the trailing quote is seen. + * Strings may not span lines unless the newline is delimited. The + * recognized escape sequences are converted upon input; all others are + * left alone, presumably to later be converted by other code. + * Quotes may be included in the string by escaping them, or by means of + * the double quote convention. + */ +traverse (delim) +char delim; +{ + register char *op, *cp, ch; + static char *esc_ch = "ntfr\\\"'"; + static char *esc_val = "\n\t\f\r\\\"\'"; + char *index(); + + for (op=yytext; (*op = input()) != EOF; op++) { + if (*op == delim) { + if ((*op = input()) == EOF) + break; + if (*op == delim) + continue; /* double quote convention; keep one */ + else { + unput (*op); + break; /* normal exit */ + } + + } else if (*op == '\n') { /* error recovery exit */ + *op = '\0'; + cl_error (E_UERR, "Newline while processing string"); + break; + + } else if (*op == '\\') { + if ((*op = input()) == EOF) { + break; + } else if (*op == '\n') { + --op; /* explicit continuation */ + while ((ch = input()) && isspace(ch) || ch == '#') { + if (ch == '#') + while ((ch = input()) && ch != '\n') + ; + } + unput (ch); + continue; + } else if ((cp = index (esc_ch, *op)) != NULL) { + *op = esc_val[cp-esc_ch]; + } else if (isdigit (*op)) { /* '\0DD' octal constant */ + *op -= '0'; + while (isdigit (ch = input())) + *op = (*op * 8) + (ch - '0'); + unput (ch); + } else { + ch = *op; /* unknown escape sequence, */ + *op++ = '\\'; /* leave it alone. */ + *op = ch; + } + } + } + + *op = '\0'; + yyleng = (op - yytext); +} +int yyvstop[] = { +0, + +37, +0, + +1, +37, +0, + +35, +0, + +17, +37, +0, + +34, +37, +0, + +36, +37, +0, + +30, +37, +0, + +29, +37, +0, + +37, +0, + +37, +0, + +37, +0, + +37, +0, + +37, +0, + +26, +37, +0, + +31, +32, +37, +0, + +37, +0, + +37, +0, + +37, +0, + +27, +37, +0, + +37, +0, + +25, +37, +0, + +37, +0, + +24, +37, +0, + +1, +37, +0, + +4, +17, +37, +0, + +1, +0, + +13, +0, + +30, +0, + +16, +0, + +14, +0, + +20, +0, + +18, +0, + +2, +0, + +19, +0, + +32, +0, + +23, +0, + +21, +0, + +32, +0, + +31, +32, +0, + +31, +0, + +31, +0, + +10, +0, + +12, +0, + +8, +0, + +11, +0, + +6, +0, + +9, +0, + +28, +0, + +3, +0, + +5, +0, + +15, +0, + +1, +0, + +4, +0, + +4, +13, +0, + +22, +0, + +33, +0, + +32, +0, + +7, +0, + +32, +0, + +33, +0, + +33, +0, +0}; +# define YYTYPE char +struct yywork { YYTYPE verify, advance; } yycrank[] = { +0,0, 0,0, 1,3, 0,0, +0,0, 0,0, 0,0, 0,0, +0,0, 0,0, 1,4, 1,5, +61,0, 0,0, 0,0, 4,28, +0,0, 0,0, 0,0, 13,35, +13,36, 0,0, 0,0, 0,0, +0,0, 0,0, 0,0, 0,0, +0,0, 22,55, 22,56, 0,0, +26,59, 0,0, 1,6, 1,7, +1,8, 1,9, 4,28, 1,10, +1,7, 10,31, 13,35, 1,11, +1,12, 1,13, 1,14, 1,15, +1,16, 1,17, 2,26, 11,32, +22,55, 0,0, 24,57, 26,59, +26,60, 0,0, 0,0, 16,39, +64,69, 1,18, 1,19, 1,20, +1,21, 6,29, 1,9, 1,9, +12,34, 1,9, 11,33, 14,37, +1,9, 16,40, 2,27, 2,7, +2,8, 2,9, 18,48, 2,10, +2,7, 19,49, 21,54, 2,11, +39,63, 2,13, 2,14, 2,15, +2,16, 1,9, 38,62, 38,62, +0,0, 1,22, 0,0, 1,23, +1,9, 20,50, 0,0, 0,0, +0,0, 2,18, 2,19, 2,20, +2,21, 15,38, 15,38, 15,38, +15,38, 15,38, 15,38, 15,38, +15,38, 15,38, 15,38, 53,53, +0,0, 53,53, 0,0, 0,0, +20,51, 20,52, 38,62, 38,62, +53,53, 1,24, 1,25, 0,0, +0,0, 0,0, 20,53, 0,0, +20,53, 2,22, 0,0, 2,23, +2,9, 0,0, 9,30, 20,53, +24,58, 0,0, 0,0, 0,0, +0,0, 0,0, 0,0, 0,0, +9,30, 0,0, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +0,0, 0,0, 0,0, 0,0, +0,0, 2,24, 2,25, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 0,0, 0,0, 0,0, +0,0, 9,30, 0,0, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 9,30, 9,30, 9,30, +9,30, 17,41, 0,0, 17,42, +17,42, 17,42, 17,42, 17,42, +17,42, 17,42, 17,42, 17,42, +17,42, 17,43, 0,0, 0,0, +0,0, 0,0, 27,60, 0,0, +17,44, 17,45, 17,44, 17,46, +17,46, 17,44, 27,60, 27,0, +41,41, 41,41, 41,41, 41,41, +41,41, 41,41, 41,41, 41,41, +41,41, 41,41, 0,0, 0,0, +0,0, 0,0, 0,0, 17,47, +52,67, 0,0, 0,0, 0,0, +41,62, 41,62, 0,0, 0,0, +17,44, 17,45, 17,44, 17,46, +17,46, 17,44, 0,0, 0,0, +27,60, 0,0, 0,0, 0,0, +0,0, 27,60, 0,0, 0,0, +0,0, 0,0, 0,0, 0,0, +0,0, 0,0, 0,0, 17,47, +0,0, 52,53, 27,61, 52,53, +41,62, 41,62, 27,60, 27,60, +0,0, 27,60, 52,53, 0,0, +27,60, 43,64, 43,64, 43,64, +43,64, 43,64, 43,64, 43,64, +43,64, 43,64, 43,64, 0,0, +0,0, 0,0, 0,0, 0,0, +0,0, 27,60, 44,44, 44,44, +44,44, 44,44, 44,44, 44,44, +44,44, 44,44, 44,44, 44,44, +0,0, 0,0, 0,0, 0,0, +0,0, 0,0, 0,0, 44,44, +44,44, 44,44, 44,44, 44,44, +44,44, 46,65, 0,0, 46,65, +0,0, 0,0, 46,66, 46,66, +46,66, 46,66, 46,66, 46,66, +46,66, 46,66, 46,66, 46,66, +60,60, 0,0, 44,47, 0,0, +0,0, 0,0, 0,0, 0,0, +60,60, 60,0, 0,0, 44,44, +44,44, 44,44, 44,44, 44,44, +44,44, 62,65, 0,0, 62,65, +0,0, 0,0, 62,68, 62,68, +62,68, 62,68, 62,68, 62,68, +62,68, 62,68, 62,68, 62,68, +0,0, 0,0, 44,47, 0,0, +0,0, 0,0, 0,0, 0,0, +0,0, 0,0, 60,60, 0,0, +0,0, 0,0, 0,0, 60,60, +65,68, 65,68, 65,68, 65,68, +65,68, 65,68, 65,68, 65,68, +65,68, 65,68, 0,0, 0,0, +0,0, 0,0, 0,0, 0,0, +60,60, 60,60, 0,0, 60,60, +0,0, 0,0, 60,60, 66,66, +66,66, 66,66, 66,66, 66,66, +66,66, 66,66, 66,66, 66,66, +66,66, 0,0, 0,0, 0,0, +0,0, 0,0, 69,70, 60,60, +69,69, 69,69, 69,69, 69,69, +69,69, 69,69, 69,69, 69,69, +69,69, 69,69, 70,70, 70,70, +70,70, 70,70, 70,70, 70,70, +70,70, 70,70, 70,70, 70,70, +0,0}; +struct yysvf yysvec[] = { +0, 0, 0, +yycrank+-1, 0, 0, +yycrank+-41, yysvec+1, 0, +yycrank+0, 0, yyvstop+1, +yycrank+6, 0, yyvstop+3, +yycrank+0, 0, yyvstop+6, +yycrank+4, 0, yyvstop+8, +yycrank+0, 0, yyvstop+11, +yycrank+0, 0, yyvstop+14, +yycrank+102, 0, yyvstop+17, +yycrank+3, 0, yyvstop+20, +yycrank+9, 0, yyvstop+23, +yycrank+7, 0, yyvstop+25, +yycrank+10, 0, yyvstop+27, +yycrank+10, 0, yyvstop+29, +yycrank+57, 0, yyvstop+31, +yycrank+12, 0, yyvstop+33, +yycrank+179, 0, yyvstop+36, +yycrank+17, 0, yyvstop+40, +yycrank+20, 0, yyvstop+42, +yycrank+59, 0, yyvstop+44, +yycrank+19, 0, yyvstop+46, +yycrank+20, 0, yyvstop+49, +yycrank+0, 0, yyvstop+51, +yycrank+16, 0, yyvstop+54, +yycrank+0, 0, yyvstop+56, +yycrank+23, 0, yyvstop+59, +yycrank+-241, 0, yyvstop+62, +yycrank+0, yysvec+4, yyvstop+66, +yycrank+0, 0, yyvstop+68, +yycrank+0, yysvec+9, yyvstop+70, +yycrank+0, 0, yyvstop+72, +yycrank+0, 0, yyvstop+74, +yycrank+0, 0, yyvstop+76, +yycrank+0, 0, yyvstop+78, +yycrank+0, yysvec+13, 0, +yycrank+0, 0, yyvstop+80, +yycrank+0, 0, yyvstop+82, +yycrank+22, yysvec+15, yyvstop+84, +yycrank+23, 0, yyvstop+86, +yycrank+0, 0, yyvstop+88, +yycrank+204, 0, yyvstop+90, +yycrank+0, yysvec+17, yyvstop+92, +yycrank+265, 0, 0, +yycrank+282, 0, 0, +yycrank+0, yysvec+44, yyvstop+95, +yycrank+310, yysvec+44, 0, +yycrank+0, 0, yyvstop+97, +yycrank+0, 0, yyvstop+99, +yycrank+0, 0, yyvstop+101, +yycrank+0, 0, yyvstop+103, +yycrank+0, 0, yyvstop+105, +yycrank+230, 0, yyvstop+107, +yycrank+44, 0, yyvstop+109, +yycrank+0, 0, yyvstop+111, +yycrank+0, yysvec+22, 0, +yycrank+0, 0, yyvstop+113, +yycrank+0, 0, yyvstop+115, +yycrank+0, 0, yyvstop+117, +yycrank+0, yysvec+26, yyvstop+119, +yycrank+-367, 0, yyvstop+121, +yycrank+-2, yysvec+60, yyvstop+123, +yycrank+342, 0, 0, +yycrank+0, 0, yyvstop+126, +yycrank+2, yysvec+43, yyvstop+128, +yycrank+368, 0, 0, +yycrank+391, yysvec+44, yyvstop+130, +yycrank+0, 0, yyvstop+132, +yycrank+0, yysvec+65, yyvstop+134, +yycrank+408, 0, yyvstop+136, +yycrank+418, 0, yyvstop+138, +0, 0, 0}; +struct yywork *yytop = yycrank+475; +struct yysvf *yybgin = yysvec+1; +char yymatch[] = { +00 ,01 ,01 ,01 ,01 ,01 ,01 ,01 , +01 ,011 ,012 ,01 ,01 ,01 ,01 ,01 , +01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 , +01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 , +011 ,01 ,01 ,01 ,01 ,01 ,01 ,01 , +01 ,01 ,01 ,'+' ,01 ,'+' ,01 ,01 , +'0' ,'0' ,'0' ,'0' ,'0' ,'0' ,'0' ,'0' , +'0' ,'0' ,01 ,01 ,01 ,01 ,01 ,01 , +01 ,'A' ,'B' ,'A' ,'D' ,'D' ,'A' ,'G' , +'G' ,'G' ,'G' ,'G' ,'G' ,'G' ,'G' ,'G' , +'G' ,'G' ,'G' ,'G' ,'G' ,'G' ,'G' ,'G' , +'X' ,'G' ,'G' ,01 ,01 ,01 ,01 ,01 , +01 ,'A' ,'B' ,'A' ,'D' ,'D' ,'A' ,'G' , +'G' ,'G' ,'G' ,'G' ,'G' ,'G' ,'G' ,'G' , +'G' ,'G' ,'G' ,'G' ,'G' ,'G' ,'G' ,'G' , +'X' ,'G' ,'G' ,01 ,01 ,01 ,01 ,01 , +0}; +char yyextra[] = { +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}; +#ifndef lint +static char ncform_sccsid[] = "@(#)ncform 1.6 88/02/08 SMI"; /* from S5R2 1.2 */ +#endif + +int yylineno =1; +# define YYU(x) x +# define NLSTATE yyprevious=YYNEWLINE +char yytext[YYLMAX]; +struct yysvf *yylstate [YYLMAX], **yylsp, **yyolsp; +char yysbuf[YYLMAX]; +char *yysptr = yysbuf; +int *yyfnd; +extern struct yysvf *yyestate; +int yyprevious = YYNEWLINE; +yylook(){ + register struct yysvf *yystate, **lsp; + register struct yywork *yyt; + struct yysvf *yyz; + int yych, yyfirst; + struct yywork *yyr; +# ifdef LEXDEBUG + int debug; +# endif + char *yylastch; + /* start off machines */ +# ifdef LEXDEBUG + debug = 0; +# endif + yyfirst=1; + if (!yymorfg) + yylastch = yytext; + else { + yymorfg=0; + yylastch = yytext+yyleng; + } + for(;;){ + lsp = yylstate; + yyestate = yystate = yybgin; + if (yyprevious==YYNEWLINE) yystate++; + for (;;){ +# ifdef LEXDEBUG + if(debug)fprintf(yyout,"state %d\n",yystate-yysvec-1); +# endif + yyt = yystate->yystoff; + if(yyt == yycrank && !yyfirst){ /* may not be any transitions */ + yyz = yystate->yyother; + if(yyz == 0)break; + if(yyz->yystoff == yycrank)break; + } + *yylastch++ = yych = input(); + yyfirst=0; + tryagain: +# ifdef LEXDEBUG + if(debug){ + fprintf(yyout,"char "); + allprint(yych); + putchar('\n'); + } +# endif + yyr = yyt; + if ( (int)yyt > (int)yycrank){ + yyt = yyr + yych; + if (yyt <= yytop && yyt->verify+yysvec == yystate){ + if(yyt->advance+yysvec == YYLERR) /* error transitions */ + {unput(*--yylastch);break;} + *lsp++ = yystate = yyt->advance+yysvec; + goto contin; + } + } +# ifdef YYOPTIM + else if((int)yyt < (int)yycrank) { /* r < yycrank */ + yyt = yyr = yycrank+(yycrank-yyt); +# ifdef LEXDEBUG + if(debug)fprintf(yyout,"compressed state\n"); +# endif + yyt = yyt + yych; + if(yyt <= yytop && yyt->verify+yysvec == yystate){ + if(yyt->advance+yysvec == YYLERR) /* error transitions */ + {unput(*--yylastch);break;} + *lsp++ = yystate = yyt->advance+yysvec; + goto contin; + } + yyt = yyr + YYU(yymatch[yych]); +# ifdef LEXDEBUG + if(debug){ + fprintf(yyout,"try fall back character "); + allprint(YYU(yymatch[yych])); + putchar('\n'); + } +# endif + if(yyt <= yytop && yyt->verify+yysvec == yystate){ + if(yyt->advance+yysvec == YYLERR) /* error transition */ + {unput(*--yylastch);break;} + *lsp++ = yystate = yyt->advance+yysvec; + goto contin; + } + } + if ((yystate = yystate->yyother) && (yyt= yystate->yystoff) != yycrank){ +# ifdef LEXDEBUG + if(debug)fprintf(yyout,"fall back to state %d\n",yystate-yysvec-1); +# endif + goto tryagain; + } +# endif + else + {unput(*--yylastch);break;} + contin: +# ifdef LEXDEBUG + if(debug){ + fprintf(yyout,"state %d char ",yystate-yysvec-1); + allprint(yych); + putchar('\n'); + } +# endif + ; + } +# ifdef LEXDEBUG + if(debug){ + fprintf(yyout,"stopped at %d with ",*(lsp-1)-yysvec-1); + allprint(yych); + putchar('\n'); + } +# endif + while (lsp-- > yylstate){ + *yylastch-- = 0; + if (*lsp != 0 && (yyfnd= (*lsp)->yystops) && *yyfnd > 0){ + yyolsp = lsp; + if(yyextra[*yyfnd]){ /* must backup */ + while(yyback((*lsp)->yystops,-*yyfnd) != 1 && lsp > yylstate){ + lsp--; + unput(*yylastch--); + } + } + yyprevious = YYU(*yylastch); + yylsp = lsp; + yyleng = yylastch-yytext+1; + yytext[yyleng] = 0; +# ifdef LEXDEBUG + if(debug){ + fprintf(yyout,"\nmatch "); + sprint(yytext); + fprintf(yyout," action %d\n",*yyfnd); + } +# endif + return(*yyfnd++); + } + unput(*yylastch); + } + if (yytext[0] == 0 /* && feof(yyin) */) + { + yysptr=yysbuf; + return(0); + } + yyprevious = yytext[0] = input(); + if (yyprevious>0) + output(yyprevious); + yylastch=yytext; +# ifdef LEXDEBUG + if(debug)putchar('\n'); +# endif + } + } +yyback(p, m) + int *p; +{ +if (p==0) return(0); +while (*p) + { + if (*p++ == m) + return(1); + } +return(0); +} + /* the following are only used in the lex library */ +yyinput(){ + return(input()); + } +yyoutput(c) + int c; { + output(c); + } +yyunput(c) + int c; { + unput(c); + } diff --git a/pkg/cl/lists.c b/pkg/cl/lists.c new file mode 100644 index 00000000..d42b5923 --- /dev/null +++ b/pkg/cl/lists.c @@ -0,0 +1,125 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "config.h" +#include "mem.h" +#include "operand.h" +#include "param.h" +#include "task.h" +#include "errs.h" +#include "proto.h" + + +/* + * LISTS -- Access lists for list-structured parameters. + */ + +extern char *eofstr; +extern char *nullstr; +extern int cldebug; + + +/* READLIST -- Read next value from list-structured parameter *pp and return + * an operand. Operand will be UNDEF if there was no file or cannot open the + * named file (this will generate a query for the param) or eofstr if eof. + * As a special case, check for the value of the param being the string "stdin" + * and read from the current standard input if it is. + * Call error() if get ferror while reading or can't open list file. + */ +struct operand +readlist ( + struct param *pp +) +{ + struct operand result; + int bastype; + char *line; + + result.o_type = OT_INT; /* in case we make an undef op */ + line = pp->p_listval; + + if ((pp->p_valo.o_type & OT_UNDEF) || *pp->p_val.v_s == '\0') { + /* no list file name. */ + pp->p_flags &= ~P_LEOF; + setopundef (&result); + return (result); + } + + if (pp->p_listfp == NULL && !(pp->p_flags & P_LEOF)) { + char *filename = pp->p_val.v_s; + if (!strcmp (filename, "STDIN") || !strcmp (filename, "stdin")) + pp->p_listfp = currentask->t_stdin; + else if ((pp->p_listfp = fopen (filename, "r")) == NULL) { + /* should we tell user what's happening? + cl_error (E_UERR|E_P, "can not open list file `%s'", + pp->p_val.v_s); + */ + setopundef (&result); + return (result); + } + } + + bastype = pp->p_type & OT_BASIC; + + if (pp->p_listfp != NULL) { +again: fgets (line, SZ_LINE, pp->p_listfp); + if (ferror (pp->p_listfp)) { + closelist (pp); + /* Don't just let it go as undefined if get an actual error. */ + cl_error (E_UERR|E_P, "list file read err"); + + } else if (feof (pp->p_listfp)) { + closelist (pp); + pp->p_flags |= P_LEOF; + result = makeop (eofstr, OT_STRING); + + } else { + char *index(), *nlp, *ip; + + nlp = index (line, '\n'); + if (nlp != NULL) + *nlp = '\0'; + + /* If not simple list structured struct type parameter (used + * to get raw lines from a text file), ignore blank lines and + * comments lines in the list. + */ + if (bastype != OT_STRING || + pp->p_type & (PT_FILNAM|PT_GCUR|PT_IMCUR|PT_UKEY)) { + + for (ip=line; *ip && (*ip == ' ' || *ip == '\t'); ip++) + ; + if (*ip == EOS || *ip == '#') + goto again; + } + + result = makeop (line, bastype); + } + + } else + result = makeop (eofstr, OT_STRING); + + return (result); +} + + +/* CLOSELIST -- Close the list file in list-structured param pp. + * We assume (pp->p_type & PT_LIST) but do check that the file is not + * already closed and that we're not closing the real stdin. + */ +void +closelist ( + register struct param *pp +) +{ + if (pp->p_listfp != NULL) { + if (pp->p_listfp != stdin) + fclose (pp->p_listfp); + pp->p_listfp = NULL; + } +} diff --git a/pkg/cl/login.cl b/pkg/cl/login.cl new file mode 100644 index 00000000..a2255d9c --- /dev/null +++ b/pkg/cl/login.cl @@ -0,0 +1,97 @@ +# LOGIN.CL -- User login file for the IRAF command language. + +# Identify login.cl version (checked in images.cl). +if (defpar ("logver")) + logver = "IRAF V2.15 Oct 2009" + +set home = "pkg$ecl/" +set imdir = "uparm$" +set uparm = "home$uparm/" +set userid = "ECLTEST" + +# Set the terminal type. +stty xgterm + +# Uncomment and edit to change the defaults. +#set editor = vi +#set printer = lw +#set stdimage = imt800 +#set stdimcur = stdimage +#set stdplot = lw +#set clobber = no +#set filewait = yes +#set cmbuflen = 512000 +#set min_lenuserarea = 24000 +#set imtype = "imh" + +# IMTOOL/XIMAGE stuff. Set node to the name of your workstation to +# enable remote image display. +#set node = "" + +# CL parameters you might want to change. +#ehinit = "nostandout eol noverify" +#epinit = "standout showall" +showtype = yes + +# Environment values you might want to change. +#reset erract = "noabort notrace noclear flpr" ; keep +#reset erract = "abort trace flpr" ; keep + +# Default USER package; extend or modify as you wish. Note that this can +# be used to call FORTRAN programs from IRAF. + +package user + +task $adb $bc $cal $cat $comm $cp $csh $date $dbx $df $diff = "$foreign" +task $du $find $finger $ftp $grep $lpq $lprm $ls $mail $make = "$foreign" +task $man $mon $mv $nm $od $ps $rcp $rlogin $rsh $ruptime = "$foreign" +task $rwho $sh $spell $sps $strings $su $telnet $tip $top = "$foreign" +task $touch $vi $emacs $w $wc $less $rusers $sync $pwd $gdb = "$foreign" + +task $xc $mkpkg $generic $rtar $wtar $buglog = "$foreign" +#task $fc = "$xc -h $* -limfort -lsys -lvops -los" +task $fc = ("$" // envget("iraf") // "unix/hlib/fc.csh" // + " -h $* -limfort -lsys -lvops -los") +task $nbugs = ("$(setenv EDITOR 'buglog -e';" // + "less -Cqm +G " // envget ("iraf") // "local/bugs.*)") +task $cls = "$clear;ls" + +if (access ("loginuser.cl")) + cl < "loginuser.cl" +; + +keep; clpackage + +prcache directory +cache directory page type help + +# Print the message of the day. +if (access (".hushiraf")) + menus = no +else { + clear; type hlib$motd +} + + +# Delete any old MTIO lock (magtape position) files. +if (deftask ("mtclean")) + mtclean +else + delete uparm$mt?.lok,uparm$*.wcs verify- + +# List any packages you want loaded at login time, ONE PER LINE. +images # general image operators +plot # graphics tasks +dataio # data conversions, import export +lists # list processing + +# The if(deftask...) is needed for V2.9 compatibility. +if (deftask ("proto")) + proto # prototype or ad hoc tasks + +tv # image display +utilities # miscellaneous utilities +noao # optical astronomy packages + +keep + diff --git a/pkg/cl/logout.cl b/pkg/cl/logout.cl new file mode 100644 index 00000000..f5ca4f37 --- /dev/null +++ b/pkg/cl/logout.cl @@ -0,0 +1,5 @@ +# LOGOUT.CL -- Executed when you log out of the CL. Keep this around in the CL +# directory just to make sure this feature continues to work. + +history (100, >> "uparm$history.cl") +time diff --git a/pkg/cl/main.c b/pkg/cl/main.c new file mode 100644 index 00000000..0471f4c7 --- /dev/null +++ b/pkg/cl/main.c @@ -0,0 +1,716 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_fset +#define import_main +#define import_stdio +#define import_error +#define import_setjmp +#define import_knames +#define import_prtype +#define import_xwhen +#define import_xnames +#include + +#include +#include "config.h" +#include "grammar.h" +#include "opcodes.h" +#include "operand.h" +#include "param.h" +#include "clmodes.h" +#include "task.h" +#include "errs.h" +#include "mem.h" +#include "proto.h" + + +#define CLDIR "cl$" +#define HOSTLIB "hlib$" + +/* + * MAIN -- The main program of the CL. + * + * Repetitively call yyparse() and run() until hit eof (or "bye") during + * the lowest cl. The instructions exec and bye change the pc so that + * new code is compiled and run in a recursive fashion without having to + * call run() itself recursively. + * + * TODO: + * check access rights of file-type params in inspect. + * add < and > chars to mode param. + * all the other TODO's and more i'm sure... + */ + +#define FOREGROUND 0 +#define BACKGROUND 1 +#define BKG_QUANTUM 30 /* period(sec) bkgjob checkup */ +#define MAX_INTERRUPTS 5 /* max interrupts of a task */ +#define LEN_INTRSTK 10 /* max nesting of saved interrupts */ +typedef int (*PFI)(); + +extern int yydebug; /* print each parser state if set */ +extern FILE *yyin; /* where parser reads from */ +extern int yeof; /* set when yacc sees eof */ +extern int dobkg; /* set when code is to be done in bkg */ +extern int bkgno; /* job number if bkg job */ + +int cldebug = 0; /* print out lots of goodies if > 0 */ +int cltrace = 0; /* trace instruction execution if > 0 */ + +static PFI old_onipc; /* X_IPC handler chained to onint() */ +static long *jumpcom; /* IRAF Main setjmp/longjmp buffer */ +static jmp_buf jmp_save; /* save IRAF Main jump vector */ +static jmp_buf jmp_clexit; /* clexit() jumps here */ +static int intr_sp; /* interrupt save stack pointer */ +static XINT intr_save[LEN_INTRSTK]; /* the interrupt save stack */ +memel cl_dictbuf[DICTSIZE]; /* the dictionary area */ + +jmp_buf errenv; /* cl_error() jumps here */ +jmp_buf intenv; /* X_INT during process jumps here */ +int validerrenv; /* stays 0 until errenv gets set */ +int loggingout; /* set while processing logout file */ +int gologout; /* set when logout() is typed */ +int alldone; /* set by oneof when popping firstask */ +int recursion; /* detect error recursion in ONERROR */ +int errlev; /* detect error recursion in CL_ERROR */ +int ninterrupts; /* number of onint() calls per task */ +long cpustart, clkstart; /* starting cpu, clock times if bkg */ +int logout_status = 0; /* optional status arg to logout() */ + + +static void execute(); +static void login(), logout(); +static void startup(), shutdown(); + +extern void ZDOJMP(); +extern void c_xwhen(), onint(); +extern int yyparse(); + + +/* C_MAIN -- Called by the SPP procedure in cl.x to fire up the CL. + * In effect we are chained to the IRAF Main, being called immediately after + * the file system, etc. is initialized. When we exit we signal that the + * interpreter be skipped, proceeding directly to process shutdown. + */ +int +c_main ( + int *prtype, /* process type (connected, detached) */ + PKCHAR *bkgfile, /* bkgfile filename if detached */ + PKCHAR *cmd /* host command line */ +) +{ + XINT bp; + + /* Save the setjmp vector of the IRAF Main for restoration at clexit + * time. We need to intercept all errors and do error recovery + * ourselves during normal execution, but when the CL exits we are + * not prepared to deal with errors occuring during shutdown. + */ + XMJBUF (&bp); jumpcom = (long *)&Memc[bp]; + cl_amovi ((int *)jumpcom, (int *)jmp_save, LEN_JUMPBUF); + + /* Init clexit() in case we have to panic stop. */ + if (setjmp (jmp_clexit)) + goto exit_; + + /* Set up dictionary and catch signals. If we are background, read in + * file and jump right into run, else hand craft first task. Die if + * these fail. + */ + startup (); + + if (*prtype == PR_DETACHED) { + bkg_startup ((char *)bkgfile); + cpustart = c_cputime (0L); + clkstart = c_clktime (0L); + execute (BACKGROUND); + } else { + login ((char *) cmd); + execute (FOREGROUND); + logout(); + execute (FOREGROUND); + } + + shutdown(); + +exit_: + /* Return to the IRAF Main. The PR_EXIT code commands the main to + * skip the interpreter loop and shutdown. Restore the error + * jump vector in the IRAF Main so that it can handle errors occuring + * during shutdown; we are turning control back over to the Main. + * This is ugly, but the real problem is the jump vectors. There + * seems to be no alternative to this sort of thing... + */ + cl_amovi ((int *)jmp_save, (int *)jumpcom, LEN_JUMPBUF); + return (PR_EXIT | (logout_status << 1)); +} + + +/* CLEXIT -- Called on fatal error from error() when get an error so bad that we + * should commit suicide. + */ +void +clexit (void) +{ + longjmp (jmp_clexit, 1); +} + + +/* CLSHUTDOWN -- Public entry for shutdown. + */ +void +clshutdown (void) +{ + shutdown(); +} + + +/* STARTUP -- CL startup code. Called by onentry() at process startup. + * Allocate space for the dictionary, post exception handlers, initialize + * error recovery. + * + * NOTE: in the current implementation a fixed size buffer is allocated for + * the dictionary due to the difficulty of passing the dictionary to the + * bkg CL if a dynamically allocated dictionary is used. The problem is + * that the dictionary is full of pointers to absolute addresses, and + * we cannot control where the memory allocator in the bkg CL will allocate + * a buffer. A simple binary copy of the dictionary to different region + * of memory in the bkg CL will leave the pointers pointing into limbo. + * + * TODO: Write a pair of procedures for each major data structure to dump + * and restore the data structure in a binary array. Passing the CL context + * to the bkg CL would then be a matter of calling the dump procedure for + * each major data structure to dump the structure into the bkgfile, then + * doing a matching restore in the bkg CL to restore the data structure + * to a different region of memory. The ENV package does this already. + * The only alternative would be to use indices rather than pointers in + * the dictionary, which is not what C likes to do. + */ +static void +startup (void) +{ + void onint(), onipc(), c_xwhen(); + + /* Set up pointers to dictionary buffer. + */ + dictionary = cl_dictbuf; + topd = 0; + maxd = DICTSIZE; + + if (cldebug) + printf ("dictionary starts at %d (0%o)\n", dictionary, dictionary); + + /* Post exception handlers for interrupt and write to IPC with no + * reader. The remaining exceptions use the standard handler. + */ + c_xwhen (X_IPC, onipc, &old_onipc); + intr_reset(); + + /* The following is a temporary solution to an initialization problem + * with pseudofile i/o. + */ + PRPSINIT(); +} + + +/* SHUTDOWN -- Call this to exit gracefully from the whole cl; never return. + * Write out any remaining PF_UPDATE'd pfiles by restoring topd to just above + * first task unless we are in batch mode, then just flush io and die.. + * So that the restor will include the cl's pfile and any other pfiles that + * might have been cached or assigned into, we force its topd to be + * below its pfile head. See the "pfp < topdp" loop in restor(). + * Don't bother with restor'ing if BATCH since we don't want to write out + * anything then anyway. + */ +static void +shutdown (void) +{ + float cpu, clk; + + pr_dumpcache (0, YES); /* flush process cache */ + clgflush(); /* flush graphics output */ + + if (firstask->t_flags & T_BATCH) { + iofinish (currentask); + if (notify()) { + cpu = (float)c_cputime(cpustart) / 1000.; + clk = (float)c_clktime(clkstart); + fprintf (stderr, "\n[%d] done %.1f %.0m %d%%\n", bkgno, + cpu, clk/60., (int)((clk > 0 ? cpu / clk : 0.) * 100.)); + } + } else { + firstask->t_topd = dereference (firstask->t_ltp) + LTASKSIZ; + restor (firstask); + } + + yy_startblock (LOG); /* flush and close log */ + close_logfile (logfile()); + clexit(); +} + + +/* EXECUTE -- Each loop corresponds to an exec in the interpreted code. + * This occurs when a script task or process is ready to run. In background + * mode, we skip the preliminaries and jump right in and interpret the + * compiled code. + */ +static void +execute (int mode) +{ + int parsestat; + XINT old_parhead; + char *curcmd(); + + alldone = 0; + gologout = 0; + if (mode == BACKGROUND) { + if (setjmp (jumpcom)) + onerr(); + goto bkg; + } + + /* Called when control stack contains only the firsttask. ONEOF sets + * alldone true when eof/bye is seen and currentask=firstask, + * terminating the loop and returning to main. + */ + do { + /* Bkg_update() checks for blocked or finished bkg jobs and prints + * a message if it finds one. This involves one or more access() + * calls so don't call it more than every 5 seconds. The errenv + * jump vector is used by cl_error() for error restart. The JUMPCOM + * vector is used to intercept system errors which would otherwise + * restart the CL. + */ + if (currentask->t_flags & T_INTERACTIVE) { + static long last_clktime; + + if (c_clktime (last_clktime) > BKG_QUANTUM) { + last_clktime = c_clktime (0L); + bkg_update (1); + } + validerrenv = 1; + setjmp (errenv); + ninterrupts = 0; + if (setjmp (jumpcom)) + onerr(); + } else if (!(currentask->t_flags & T_SCRIPT)) + setjmp (intenv); + + pc = currentask->t_bascode; + currentask->t_topd = topd; + currentask->t_topcs = topcs; + recursion = 0; + errlev = 0; + c_erract (OK); + yeof = 0; + + /* In the new CL the parser needs to know more about parameters + * than before. Hence param files may be read in during parsing. + * Since we discard the dictionary after parsing we must unlink + * these param files, and re-read them when the + * program is run. This is inefficient but appears to work. + */ + old_parhead = parhead; + + if (gologout) + yeof++; + else { + yy_startblock (LOG); /* start new history blk */ + parsestat = yyparse(); /* parse command block */ + topd = currentask->t_topd; /* discard addconst()'s */ + topcs = currentask->t_topcs; /* discard compiler temps */ + parhead = old_parhead; /* forget param files. */ + if (parsestat != 0) + cl_error (E_IERR, "parser gagged"); + } + + if (dobkg) { + bkg_spawn (curcmd()); + } else { +bkg: + if (yeof) + oneof(); /* restores previous task */ + else { + /* set stack above pc, point pc back to code */ + topos = basos = pc - 1; + pc = currentask->t_bascode; + } + + if (!alldone) + run(); /* run code starting at pc */ + } + } until (alldone); +} + + +/* LOGIN -- Hand-craft the first cl process. Push the first task to become + * currentask, set up clpackage at pachead and set cl as its first ltask. + * Add the builtin function ltasks. Run the startup file as the stdin of cl. + * If any of this fails, we die. + */ +static void +login (char *cmd) +{ + register struct task *tp; + register char *ip, *op; + struct ltask *ltp; + struct operand o; + char *loginfile = LOGINFILE; + char alt_loginfile[SZ_PATHNAME]; + char clstartup[SZ_PATHNAME]; + char clprocess[SZ_PATHNAME]; + char *arglist; + + strcpy (clstartup, HOSTLIB); + strcat (clstartup, CLSTARTUP); + strcpy (clprocess, CLDIR); + strcat (clprocess, CLPROCESS); + + tp = firstask = currentask = pushtask(); + tp->t_in = tp->t_stdin = stdin; + tp->t_out = tp->t_stdout = stdout; + tp->t_stderr = stderr; + tp->t_stdgraph = fdopen (STDGRAPH, "w"); + tp->t_stdimage = fdopen (STDIMAGE, "w"); + tp->t_stdplot = fdopen (STDPLOT, "w"); + tp->t_pid = -1; + tp->t_flags |= (T_INTERACTIVE|T_CL); + + /* Make root package. Avoid use of newpac() since pointers are not + * yet set right. + */ + pachead = topd; + curpack = (struct package *) memneed (PACKAGESIZ); + curpack->pk_name = comdstr (ROOTPACKAGE); + curpack->pk_ltp = NULL; + curpack->pk_pfp = NULL; + curpack->pk_npk = NULL; + curpack->pk_flags = 0; + + /* Make first ltask. + */ + ltp = newltask (curpack, "cl", clprocess, (struct ltask *) NULL); + tp->t_ltp = ltp; + ltp->lt_flags |= (LT_PFILE|LT_CL); + + tp->t_pfp = pfileload (ltp); /* call newpfile(), read cl.par */ + tp->t_pfp->pf_npf = NULL; + setclmodes (tp); /* uses cl's params */ + + setbuiltins (curpack); /* add more ltasks off clpackage*/ + + /* Define the second package, the "clpackage", and make it the + * current package (default package at startup). Tasks subsequently + * defined by the startup script will get put in clpackage. + */ + curpack = newpac (CLPACKAGE, "bin$"); + + /* Compile code that will run the startup script then, if it exists + * in the current directory, a login.cl script. We need to do as + * much by hand here as the forever loop in main would have if this + * code came from calling yyparse(). + */ + if (c_access (clstartup,0,0) == NO) + cl_error (E_FERR, "Cannot find startup file `%s'", clstartup); + + currentask->t_bascode = 0; + pc = 0; + o.o_type = OT_STRING; + o.o_val.v_s = clstartup; + compile (CALL, "cl"); + compile (PUSHCONST, &o); + compile (REDIRIN); + compile (EXEC); + compile (FIXLANGUAGE); + + /* The following is to permit error recovery in the event that an + * error occurs while reading the user's LOGIN.CL file. + */ + validerrenv = 1; + if (setjmp (errenv)) { + eprintf ("Error while reading login.cl file"); + eprintf (" - may need to rebuild with mkiraf\n"); + eprintf ("Fatal startup error. CL dies.\n"); + clexit(); + } + ninterrupts = 0; + if (setjmp (jumpcom)) + onerr(); + + /* Nondestructively decompose the host command line into the startup + * filename and/or the argument string. + */ + if (strncmp (cmd, "-f", 2) == 0) { + for (ip=cmd+2; *ip && isspace(*ip); ip++) + ; + for (op=alt_loginfile; *ip && ! isspace(*ip); *op++ = *ip++) + ; + *op = EOS; + + for ( ; *ip && isspace(*ip); ip++) + ; + arglist = ip; + + } else { + *alt_loginfile = EOS; + arglist = cmd; + } + + /* Copy any user supplied host command line arguments into the + * CL parameter $args to use in the startup script (for instance). + */ + o.o_type = OT_STRING; + strcpy (o.o_val.v_s, arglist); + compile (PUSHCONST, &o); + compile (ASSIGN, "args"); + + if (alt_loginfile[0]) { + if (c_access (alt_loginfile,0,0) == NO) + printf ("Warning: script file %s not found\n", alt_loginfile); + else { + o.o_val.v_s = alt_loginfile; + compile (CALL, "cl"); + compile (PUSHCONST, &o); + compile (REDIRIN); + compile (EXEC); + } + + } else if (c_access (loginfile,0,0) == NO) { + char *home = envget ("HOME"); + char global[SZ_LINE]; + + memset (global, 0, SZ_LINE); + sprintf (global, "%s/.iraf/login.cl", home); + if (c_access (global, 0, 0) == YES) { + o.o_val.v_s = global; + compile (CALL, "cl"); + compile (PUSHCONST, &o); + compile (REDIRIN); + compile (EXEC); + } else { + printf ("Warning: no login.cl found in login directory\n"); + } + + } else { + o.o_val.v_s = loginfile; + compile (CALL, "cl"); + compile (PUSHCONST, &o); + compile (REDIRIN); + compile (EXEC); + } + + compile (END); + topos = basos = pc - 1; + pc = 0; + run(); /* returns after doing the first EXEC */ + + /* Add nothing here that will effect the dictionary or the stacks. + */ + if (cldebug) + printf ("topd, pachead, parhead: %u, %u, %u\n", + topd, pachead, parhead); +} + + +/* LOGOUT -- Process the system logout file. Called when the user logs + * off in an interactive CL (not called by bkg cl's). The standard input + * of the CL is hooked to the system logout file and when the eof of the + * logout file is seen the CL really does exit. + */ +static void +logout (void) +{ + register struct task *tp; + char logoutfile[SZ_PATHNAME]; + FILE *fp; + + strcpy(logoutfile, HOSTLIB); + strcat(logoutfile, CLLOGOUT); + + if ((fp = fopen (logoutfile, "r")) == NULL) + cl_error (E_FERR, + "Cannot open system logout file `%s'", logoutfile); + + tp = firstask; + tp->t_in = tp->t_stdin = fp; + yyin = fp; + tp->t_flags = (T_CL|T_SCRIPT); + loggingout = 1; + gologout = 0; +} + + +/* MEMNEED -- Increase topd by incr INT's. Since at present the dictionary + * is fixed in size, abort if the dictionary overflows. + */ +char * +memneed ( + int incr /* amount of space desired in ints, not bytes */ +) +{ + memel *old; + + old = daddr (topd); + topd += incr; + + /* Quad alignment is desirable for some architectures. */ + if (topd & 1) + topd++; + + if (topd > maxd) + cl_error (E_IERR, "dictionary full"); + + return ((char *)old); +} + + +/* ONINT -- Called when the interrupt exception occurs, i.e., the usual user + * attention-getter. (cntrl-c on dec, delete on unix, etc.). Also called + * when we are killed as a bkg job. + * If the current task is a script or the terminal, abort execution and + * initiate error recovery. If the task is in a child process merely send + * interrupt to the child and continue execution (giving the child a chance + * to cleanup before calling error, or to ignore the interrupt entirely). + * If the task wants to terminate it will send the ERROR statement to the CL. + * If we are a bkg job, call bkg_abort to clean up (delete temp files, etc.) + * before shutting down. + */ +/* ARGSUSED */ +void +onint ( + int *vex, /* virtual exception code */ + int (**next_handler)() /* next handler to be called */ +) +{ + if (firstask->t_flags & T_BATCH) { + /* Batch task. + */ + iofinish (currentask); + bkg_abort(); + clexit(); + + } else if (currentask->t_flags & (T_SCRIPT|T_CL|T_BUILTIN)) { + /* CL task. + */ + cl_error (E_UERR, "interrupt!!!"); + + } else { + /* External task connected via IPC. Pass the interrupt on to + * the child. + */ + c_prsignal (currentask->t_pid, X_INT); + + /* Cancel any output and disable i/o on the tasks pseudofiles. + * This is necessary to cancel any i/o still buffered in the + * IPC channel. Commonly when the task is writing to STDOUT, + * for example, the CL will be writing the last buffer sent + * to the terminal, while the task waits after having already + * pushed the next buffer into the IPC. When we resume reading + * from the task we will see this buffered output on the next + * read and we wish to discard it. Leave STDERR connected to + * give a path to the terminal for recovery actions such as + * turning standout or graphics mode off. This gives the task + * a chance to cleanup but does not permit full recovery. The + * pseudofiles will be reconnected for the next task run. + */ + c_fseti (fileno(stdout), F_CANCEL, OK); + c_fseti (fileno(currentask->t_in), F_CANCEL, OK); + c_fseti (fileno(currentask->t_out), F_CANCEL, OK); + + c_prredir (currentask->t_pid, STDIN, 0); + c_prredir (currentask->t_pid, STDOUT, 0); + + /* If a subprocess is repeatedly interrupted we assume that it + * is hung in a loop and abort, advising the user to kill the + * process. + */ + if (++ninterrupts >= MAX_INTERRUPTS) + cl_error (E_UERR, "subprocess is hung; should be killed"); + else + longjmp (intenv, 1); + } + + *next_handler = NULL; +} + + +/* INTR_DISABLE -- Disable interrupts, e.g., to protect a critical section + * of code. + */ +void +intr_disable (void) +{ + PFI junk; + + if (intr_sp >= LEN_INTRSTK) + cl_error (E_IERR, "interrupt save stack overflow"); + c_xwhen (X_INT, X_IGNORE, &junk); + intr_save[intr_sp++] = (XINT) junk; +} + + +/* INTR_ENABLE -- Reenable interrupts, reposting the interrupt vector saved + * in a prior call to INTR_DISABLE. + */ +void +intr_enable (void) +{ + PFI junk; + + if (--intr_sp < 0) + cl_error (E_IERR, "interrupt save stack underflow"); + c_xwhen (X_INT, intr_save[intr_sp], &junk); +} + + +/* INTR_RESET -- Post the interrupt handler and clear the interrupt vector + * save stack. + */ +void +intr_reset (void) +{ + PFI junk; + + c_xwhen (X_INT, onint, &junk); + intr_sp = 0; +} + + +/* ONERR -- Called when system error recovery takes place. The setjmp in + * execute() overrides the setjmp (ZSVJMP) in the IRAF Main. When system error + * recovery takes place, c_erract() calls ZDOJMP to restart the IRAF Main. + * We do not want to lose the runtime context of the CL, so we restart the + * CL main instead by intercepting the vector. We get the error message from + * the system and call cl_error() which eventually does a longjmp back to + * the errenv in execute(). + */ +void +onerr (void) +{ + char errmsg[SZ_LINE]; + + c_erract (EA_RESTART); + c_errget (errmsg, SZ_LINE); + + if (recursion++) + longjmp (errenv, 1); + else + cl_error (E_UERR, errmsg); +} + + +/* CL_AMOVI -- Copy an integer sized block of memory. + */ +void +cl_amovi ( + register int *ip, + register int *op, + register int len +) +{ + while (--len) + *op++ = *ip++; +} diff --git a/pkg/cl/mem.h b/pkg/cl/mem.h new file mode 100644 index 00000000..752b3be5 --- /dev/null +++ b/pkg/cl/mem.h @@ -0,0 +1,109 @@ +/* + * MEM.H -- Define the dictionary, the stack, indices of various kinds, + * and ways of converting the indices into true address pointers. + * + * Structures that live within the dictionary may use pointers to + * point at other structures (such as the task and parameter chains) but + * things that simply point AT the dictionary and that move around are indices + * into what appears to be the array of unsigned integers called dictionary. + * This is to facilitate putting things of disparate types into the array. + */ + +/* bytes per int; + * typically used when putting things in the dictionary like strings, operands + * and codeentries. also, the pc must be advanced in ints. + * + * N.B. it is FUNDAMENTALLY ASSUMED throughout that an int is large enough to + * hold a pointer to an int. Further, although casts are used carefully as + * much as possible and so a good compiler will do much of the work, + * it is also pretty much taken for granted that all pointers are the + * same size, in particular that (char *) is the same size as (unsigned *). + */ + +#define BPI (sizeof (memel)) +#define btoi(x) ((int)((((x)+BPI-1)/BPI))) /* avoid promotion to unsigned */ +#define dtoi(x) ((int)(sizeof(double))/(sizeof(memel))*x) + +/* the dictionary starts at the top of the system break and grows as needed. + * if this is hard to do on your os, declare it as a genuine array and + * forever fix the value of maxd by initializing them in their declarations + * in compile.c. see machdep.c. + */ + + +extern memel *dictionary; /* base of the dictionary; never moves */ + +/* ---------- + * convert a dictionary index into a structure pointer. + * also, dereference a pointer to a dictionary index. + */ + +#define reference(sname,index) ((struct sname *) (&dictionary[index])) +/* +#define dereference(ptr) \ +(((unsigned)(char *)(ptr) - (unsigned)(char *)(dictionary))/BPI) +*/ +#define dereference(ptr) \ +(((char *)(ptr) - (char *)(dictionary))/BPI) + +/* ---------- + * Generic push/pop memory routines. Can be used to push/pop any integer type + * argument regardless of size, so long as it fits in a memel. + */ +#define push(v) pushmem((memel)v) +#define ppush(v) ppushmem((memel)v) +#define pop popmem + +/* ---------- + * convert a dictionary index into a genuine address; type will be + * the type of dictionary. + */ + +#define daddr(x) (&dictionary[x]) + +/* ---------- + * maxd: smallest d. index that is out of range and will give mem fault if + * referenced. commonly referred to as the "system break". + * topd: next d. index available for use, ie, it is the smallest d. index + * not in use. + * pachead: dictionary index of most recently added package. + * parhead: " pfile. + * envhead: " environment. + */ + +extern XINT maxd; +extern XINT topd; +extern XINT pachead; +extern XINT parhead; +extern XINT envhead; + +/* ---------- + * these are indices into the stack defined in stack.c. + * topcs: the smallest index into stack[], ie, the "top" index of the control + * stack since it grows downwards, that has been used. + * topos: the largest index into stack[], ie, the top of the operand stack + * since it grows upwards, that has been used. + * pc: at compile time, this is the stack[] index at which the next codeentry + * may be compiled; at run time, it is the program counter and points + * to the next codeentry to be run (it is bumped before the "execute" + * cycle begins. see run()). + * basos: not used at compile time, but when compilation ends and runtime + * begins, it is set to pc and thus serves as the base of the operand + * stack as everything below it will be compiled code. when compiling + * starts again, this, and pc, are set to zero to forcibly clear the + * operand stack. + */ + +extern memel stack[]; /* space for the stacks */ +extern XINT topcs; /* top of control stack */ +extern XINT topos; /* top of operand stack */ +extern XINT basos; /* base of operand stack */ +extern XINT pc; /* program counter */ + +/* ---------- + * reference a codeentry in stack at x. + */ +#define coderef(x) ((struct codeentry *)&stack[x]) + +extern char *memneed(); /* insures enough core, returns start */ +extern char *comdstr(); /* compile string at topd, return start */ diff --git a/pkg/cl/mkpkg b/pkg/cl/mkpkg new file mode 100644 index 00000000..0957f5af --- /dev/null +++ b/pkg/cl/mkpkg @@ -0,0 +1,180 @@ +# Make the CL. + +$call relink # make cl.e in current directory +$exit + +update: # make cl.e and install in bin$ + $call relink + $call install + ; + +relink: + # [MACHDEP] The following is machine dependent, but is exercised only + # on our software development system when changes are made to the + # grammar of the CL. On other systems the files lexyy.c, ytab.c, and + # ytab.h may be used without modification. + + $ifeq (hostid, unix) + $ifolder (lexyy.c, grammar.l) + $echo "rebuilding lexyy.c" + !lex -t grammar.l | sed -f lex.sed > lexyy.c + $endif + $ifolder (ytab.c, grammar.y) + $echo "rebuilding ytab.c" + !yacc -vd grammar.y; mv y.tab.c ytab.c; mv y.tab.h ytab.h + $endif + $endif + + $ifeq (siteid, stsci) + $ifeq (hostid, vms) + $ifolder (lexyy.c, grammar.l) + $echo "rebuilding lexyy.c" + !lex grammar.l + !@lex.com + $endif + $ifolder (ytab.c, grammar.y) + $echo "rebuilding ytab.c" + !yacc -vd grammar.y + $endif + $endif + $endif + + $update libpkg.a + + #$set xflags = "$(xflags) -x" + $omake cl.x + $omake globals.c \ + construct.h eparam.h operand.h param.h task.h + $omake opcodes.c config.h\ + construct.h errs.h grammar.h mem.h opcodes.h operand.h\ + param.h task.h +link: + $set LIBS = "-lc -lcur -lds -lstg" + $link cl.o globals.o opcodes.o libpkg.a $(LIBS) + ; + +install: + $move cl.e bin$ + ; + +libpkg.a: + #$set xflags = "$(xflags) -qx" + + binop.c \ + config.h\ + operand.h errs.h + + bkg.c \ + \ + clmodes.h config.h operand.h clmodes.h\ + mem.h errs.h param.h task.h + + builtin.c \ + \ + clmodes.h\ + config.h mem.h operand.h param.h task.h errs.h + + clprintf.c \ + config.h operand.h param.h\ + task.h errs.h + + clsystem.c \ + errs.h + + compile.c config.h\ + operand.h opcodes.h mem.h errs.h + + debug.c \ + operand.h mem.h grammar.h opcodes.h config.h param.h\ + task.h + + decl.c \ + clmodes.h operand.h mem.h grammar.h opcodes.h config.h\ + param.h task.h errs.h construct.h ytab.h + + edcap.c \ + config.h operand.h\ + param.h task.h eparam.h + + eparam.c \ + \ + config.h mem.h operand.h\ + errs.h param.h grammar.h task.h eparam.h + + errs.c \ + \ + clmodes.h\ + config.h operand.h param.h task.h mem.h errs.h\ + grammar.h construct.h + + exec.c \ + clmodes.h config.h mem.h\ + opcodes.h operand.h param.h task.h errs.h\ + grammar.h + + gquery.c \ + config.h operand.h param.h grammar.h\ + task.h clmodes.h + + gram.c \ + clmodes.h operand.h mem.h grammar.h\ + opcodes.h config.h param.h task.h errs.h construct.h\ + ytab.h + + history.c \ + config.h errs.h\ + mem.h operand.h param.h task.h clmodes.h grammar.h + + lists.c \ + config.h mem.h operand.h param.h\ + task.h errs.h + + main.c \ + \ + \ + grammar.h\ + opcodes.h operand.h param.h config.h clmodes.h task.h\ + errs.h mem.h + + modes.c \ + clmodes.h\ + config.h construct.h operand.h param.h grammar.h\ + mem.h task.h errs.h + + operand.c \ + errs.h config.h operand.h param.h grammar.h\ + mem.h task.h construct.h eparam.h + + param.c \ + config.h operand.h param.h grammar.h mem.h\ + task.h errs.h clmodes.h construct.h + + pfiles.c \ + config.h\ + errs.h operand.h mem.h param.h task.h grammar.h + + prcache.c \ + \ + config.h errs.h task.h + + scan.c \ + config.h operand.h param.h grammar.h\ + task.h errs.h + + stack.c \ + mem.h operand.h config.h param.h task.h\ + errs.h + + task.c \ + config.h operand.h param.h mem.h task.h\ + errs.h clmodes.h + + unop.c \ + config.h\ + operand.h errs.h task.h param.h + + ytab.c \ + config.h mem.h operand.h\ + param.h grammar.h opcodes.h clmodes.h task.h\ + construct.h errs.h lexyy.c lexicon.c + ; diff --git a/pkg/cl/modes.c b/pkg/cl/modes.c new file mode 100644 index 00000000..1258b032 --- /dev/null +++ b/pkg/cl/modes.c @@ -0,0 +1,1279 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#define import_ctype +#include + +#include "config.h" +#include "clmodes.h" +#include "construct.h" +#include "operand.h" +#include "param.h" +#include "grammar.h" +#include "mem.h" +#include "task.h" +#include "errs.h" +#include "proto.h" + + +/* + * MODES -- Handle the parameter mode operations, such as determining effective + * mode, checking if in range and queries. + * Also handle the global modes of the cl, such as abbreviations, menus, and + * logging. Macro defns for all but abbreviations are in clmodes.h; it is + * involved enough to be a real function in this file. + */ + +#define INIT_DELAY 3 /* sleep params, bkg_query() */ +#define DELAY_MULT 1.4 +#define MAXDELAY (60*5) /* sleep at most 5 minutes */ +#define BKQ_TIMEOUT (60*60*3) /* time out after 3 hours */ +#define SZ_PROMPTBUF SZ_LINE /* avoid string overflow */ + +extern int cldebug; +extern char *eofstr; +extern int bkgno; /* our job number, if background */ +extern int ppid; /* parent's pid, if background */ + +/* These are set, by setclmodes(), right after the cl's pfile is read. there + * is one for each special-function cl parameter. + * Once set, they are used by the macros in clmodes.h to efficiently determine + * the various function settings yet allow them to remain normal parameters. + */ +struct param *clabbrev; /* allow abbreviations? */ +struct param *clmenus; /* display tasks in curpack with prompt?*/ +struct param *clshowtype; /* display task type in menus */ +struct param *clkeeplog; /* keep all input in logfile? */ +struct param *cllexmodes; /* enable lexical mode switching */ +struct param *cllogfile; /* name of the logfile */ +struct param *clnotify; /* notify parent when bkg task is done */ +struct param *clecho; /* echo commands from scripts on stderr */ +int cllogmode = LOG_COMMANDS; /* Logging control flag */ + + +/* Calculate the effective mode for the given parameter, considering + * its own mode and the modes for the current task and the cl. + * Inhibit query mode if set on the command line or hidden but + * enable it if the param is not in range. The range test cannot be done + * here for list params because we'd have to read the list to do it. + * Return a bit-mapped code (built up of M_XXX bits) of the result. + * Since learn mode is not defined at the parameter level, pp == NULL + * is used to indicate we are just interested in M_LEARN info. + * Local variables cannot be prompted for so it is an error if their + * values are undefined. + */ +int +effmode ( + struct param *pp +) +{ + static char *localerr = + "Attempt to access undefined local variable `%s'.\n"; + + register int mode, modebits; + struct operand o; + int clmode, ltmode, pkmode, offset; + int interactive; + + /* Check if param is a local variable. If it is undefined + * this is an ERR, if defined just return mode 0 to defeat + * querying. + */ + if (pp != NULL) + if (pp->p_mode & M_LOCAL) { + if (opundef (&(pp->p_valo))) + cl_error (E_UERR, localerr, pp->p_name); + return (0); + } + + /* Determine whether or not the current task was called interactively. + * Menu mode is only permitted for tasks called interactively. + */ + interactive = 0; + if (prevtask) + interactive = (prevtask->t_flags & (T_INTERACTIVE|T_BATCH)); + if (interactive) + modebits = (M_QUERY|M_HIDDEN|M_MENU); + else + modebits = (M_QUERY|M_HIDDEN); + + clmode = scanmode (firstask->t_modep->p_val.v_s); + ltmode = scanmode (currentask->t_modep->p_val.v_s); + pkmode = -1; + + mode = 0; + if (pp != NULL) { + /* In determining the effective mode we go up the hierarchy of + * parameter, task, package, cl. The mode is taken from the first + * of these which is not automatic. + */ + if ((mode = (pp->p_mode & modebits))) + ; + else if ((mode = (ltmode & modebits))) + ; + else { + /* Check the mode of the package to which the ltask belongs, + * which need not be the "current" package. + */ + struct pfile *pfp; + + if ((pfp = currentask->t_ltp->lt_pkp->pk_pfp)) { + struct param *ppx; + ppx = paramfind (pfp, "mode", 0, YES); + if ((ppx != NULL) && (ppx != (struct param *)ERR)) + pkmode = scanmode (ppx->p_val.v_s); + } + + if (pkmode > 0 && (mode = (pkmode & modebits))) + ; + else if ((mode = (clmode & modebits))) + ; + else + mode = M_AUTO; + } + + /* Defeat query mode if param set on command line or it's a + * hidden param or if menu mode is in effect. + */ + if ((pp->p_flags & P_CLSET) || (pp->p_mode & M_HIDDEN) || + (mode & M_MENU)) + mode &= ~M_QUERY; + + /* Query unconditionally if param is out of range or undefined. + */ + if (!(mode & M_QUERY) && !(pp->p_type & PT_LIST)) { + + /* To check whether an array element is in range we + * must get the appropriate element of the array. However + * the stack must be reset so that the element can be accessed + * again by the calling routine. + */ + if (pp->p_type & PT_ARRAY) { + offset = getoffset(pp); + + poffset (offset); + paramget(pp, FN_VALUE); + + poffset (offset); + + o = popop(); + if (!inrange (pp, &o)) + mode |= M_QUERY; + + } else { + /* Use temporary scratch variable for range checking in + * this case; sometimes the value of an enumerated + * parameter would get trashed in the process. There is + * probably some deeper, darker bug lurking down there, + * but haven't found it yet, so this will suffice for now. + */ + o = pp->p_valo; + if (!inrange (pp, &o)) + mode |= M_QUERY; + } + } + } + + /* Enable learn mode only for tasks called interactively - don't bother + * to learn parameters if the task is called from a script or in batch + * mode. + */ + if (interactive) + mode |= (clmode & M_LEARN) | (ltmode & M_LEARN); + + return (mode); +} + + +/* TASKMODE -- Determine the effective mode for a task. + */ +int +taskmode ( + register struct task *tp +) +{ + register int modebits, mode; + struct pfile *pfp; + int clmode, pkmode, ltmode; + int interactive, learn; + + /* Determine whether or not the task was called interactively. + * Menu mode is only permitted for tasks called interactively. + */ + interactive = 0; + if (next_task(tp)) + interactive = (next_task(tp)->t_flags & (T_INTERACTIVE|T_BATCH)); + if (interactive) + modebits = (M_QUERY|M_HIDDEN|M_MENU); + else + modebits = (M_QUERY|M_HIDDEN); + + ltmode = scanmode (tp->t_modep->p_val.v_s); + clmode = scanmode (firstask->t_modep->p_val.v_s); + learn = ((ltmode|clmode) & M_LEARN); + + /* If the mode of the task is anything but AUTO we are done. + */ + if ((mode = (ltmode & modebits))) + if (interactive || !(mode & M_MENU)) + return (mode|learn); + + /* If the package to which the task belongs has a pfile and the mode + * of the package is anything but AUTO, we are done. + */ + if ((pfp = tp->t_ltp->lt_pkp->pk_pfp)) { + struct param *ppx; + + pkmode = ERR; + ppx = paramfind (pfp, "mode", 0, YES); + if ((ppx != NULL) && (ppx != (struct param *)ERR)) + pkmode = scanmode (ppx->p_val.v_s); + + if (pkmode != ERR && (mode = (pkmode & modebits))) + if (interactive || !(mode & M_MENU)) + return (mode|learn|(pkmode&M_LEARN)); + } + + /* Return the CL mode (menu mode not permitted at the CL level). + */ + return (clmode); +} + + +/* QUERY -- Query the user for the value of a parameter. Prompt with the + * current value if any. Keep this up until we can push a reasonable value. + * Also, store the new value in the parameter (except for list params, where, + * since the values are not kept, all that may change is P_LEOF if seen). + * Give prompt, or name if none, current value and range if int, real or + * filename. Accept CR to leave value unchanged, else take the string + * entered to be the new value. Repeat until parameter value is in range. + * We mean to talk straight to the user here; thus, interact with the real + * stdio, not the effective t_stdio, so that redirections do not get in + * the way. In batch mode, a forced query is handled by writing a + * message on the terminal of the parent cl (the original stderr), and + * leaving some info describing the query in a file in uparm (if there is + * no uparm, we abort). We then loop, waiting for the user to run "service" + * in the interactive cl to service the query, leaving the answer in a + * another file which we read and then delete. If we wait a long time and + * get no response, we timeout. + */ +void +query ( + struct param *pp +) +{ + static char *oormsg = + "ERROR: Parameter value is out of range; try again"; + register char *ip; + char buf[SZ_PROMPTBUF+1]; + struct operand o; + int bastype, batch, arrflag, offset, n_ele, max_ele, fd; + char *index(), *nlp, *nextstr(); + char *bkg_query(), *query_status; + char *abuf; + + bastype = pp->p_type & OT_BASIC; + batch = firstask->t_flags & T_BATCH; + arrflag = pp->p_type & PT_ARRAY; + + if (arrflag) { /* We may access the array many */ + offset = getoffset (pp); /* times, so save the offset and */ + /* push it when necessary. */ + poffset (offset); + max_ele = size_array (pp) - offset; + } else + max_ele = 1; + + + forever { + if (batch) { + /* Query from a background job. + */ + query_status = bkg_query (buf, SZ_PROMPTBUF, pp); + + } else if (pp->p_type & (PT_GCUR|PT_IMCUR)) { + /* Read a graphics cursor. + */ + char source[33]; + int cursor; + + /* Determine the source of graphics cursor input, chosen from + * either the graphics or image cursor or the terminal. + */ + if (pp->p_type & PT_GCUR) { + if (c_envfind ("stdgcur", source, 32) <= 0) + strcpy (source, "stdgraph"); + } else { + if (c_envfind ("stdimcur", source, 32) <= 0) + strcpy (source, "stdimage"); + } + + if (strcmp (source, "stdgraph") == 0) + cursor = STDGRAPH; + else if (strcmp (source, "stdimage") == 0) + cursor = STDIMAGE; + else + goto text_query; /* get value from terminal */ + + /* Read a physical graphics cursor. + */ + pp->p_flags &= ~P_LEOF; + if (cursor == STDIMAGE) { + /* The following is a kludge used to temporarily implement + * the logical image cursor read. In the future this will + * be eliminated, and the c_rcursor call below (cursor + * mode) will be used for stdimage as well as for stdgraph. + * The present code (IMDRCUR) goes directly to the display + * server to get the cursor value, bypassing cursor mode + * and the (currently nonexistent) stdimage kernel. + */ + char str[SZ_LINE+1], keystr[10]; + int wcs, key; + float x, y; + + if (c_imdrcur ("stdimage", + &x,&y,&wcs,&key,str,SZ_LINE, 1, 1) == EOF) { + query_status = NULL; + + } else { + if (isprint(key) && !isspace(key)) + sprintf (keystr, "%c", key); + else + sprintf (keystr, "\\%03o", key); + sprintf (buf, "%.3f %.3f %d %s %s\n", + x, y, wcs, keystr, str); + query_status = (char *) ((XINT)strlen(buf)); + } + + } else if (c_rcursor (cursor, buf, SZ_PROMPTBUF) == EOF) { + query_status = NULL; + } else + query_status = (char *) ((XINT)strlen(buf)); + + } else if (pp->p_type & PT_UKEY) { + /* Read a user keystroke command from the terminal. + */ + pp->p_flags &= ~P_LEOF; + if (c_rdukey (buf, SZ_PROMPTBUF) == EOF) + query_status = NULL; + else + query_status = (char *) ((XINT)strlen(buf)); + + } else { +text_query: fd = spf_open (buf, SZ_PROMPTBUF); + pquery (pp, fdopen(fd,"a")); + spf_close (fd); + + c_stgputline ((XINT)STDOUT, buf); + if (c_stggetline ((XINT)STDIN, buf, SZ_PROMPTBUF) > 0) + query_status = (char *) ((XINT) strlen(buf)); + else + query_status = NULL; + } + + ip = buf; + + /* Set o to the current value of the parameter. Beware that some + * of the logical branches which follow assume that struct o has + * been initialized to the current value of the parameter. + */ + if (pp->p_type & PT_LIST) + setopundef (&o); + else if (arrflag) { + paramget(pp, FN_VALUE); + poffset (offset); + o = popop(); + } else + o = pp->p_valo; + + /* Handle eof, a null-length line (lone carriage return), + * and line with more than SZ_LINE chars. Ignore leading whitespace + * if basic type is not string. + */ + if (query_status == NULL) { + /* Typing eof will use current value (as will a lone + * newline) but if param is a list, it is a meaningful + * answer. + */ + if (pp->p_type & PT_LIST) { + closelist (pp); /* close an existing file */ + pp->p_flags |= P_LEOF; + o = makeop (eofstr, OT_STRING); + break; + } + goto testval; + } + + /* Ignore leading whitespace if it is not significant for this + * datatype. Do this before testing for empty line, so that a + * return such as " \n" is equivalent to "\n". I.e., do not + * penalize the user if they type the space bar by accident before + * typing return to accept the default value. + */ + if (bastype != OT_STRING || (pp->p_type & (PT_FILNAM|PT_PSET))) + while (*ip == ' ' || *ip == '\t') + ip++; + + if (*ip == '\n') { + /* Blank lines usually just accept the current value + * but if the param is a string and is undefined, + * it sets the string to a (defined) nullstring. + */ + *ip = '\0'; + if (bastype == OT_STRING && opundef (&o)) + o = makeop (ip, bastype); + else + goto testval; + } + + if ((nlp = index (ip, '\n')) != NULL) + *nlp = '\0'; /* cancel the newline */ + else + goto testval; + + /* Finally, we have handled the pathological cases... + */ + if ((pp->p_type & PT_LIST) && + (!strcmp (ip,eofstr) || !strcmp (ip,"eof"))) { + + closelist (pp); + pp->p_flags |= P_LEOF; + o = makeop (eofstr, OT_STRING); + break; + + } else { + if (arrflag) { + /* In querying for arrays we may set more than one + * element of the array in a single query. However + * we must set the first element. So we will pretend + * to be a scalar until that first element is set + * and then enter a loop where we may set other + * elements. + */ + abuf = ip; + ip = nextstr(&abuf, stdin); + if (ip == NULL || ip == (char *) ERR || ip == undefval) + goto testval; + } + + o = makeop (ip, bastype); + } + +testval: + /* If parameter value is in range, we are done. If it is out of + * range and we are a batch job or an interactive terminal job, + * print an error message and request that the user enter a legal + * value. If the CL is being run taking input from a file, abort, + * else we will go into a loop reading illegal values from the + * input file and printing out lots of error messages. + */ + if (inrange (pp, &o)) + break; + else if (batch) + eprintf ("\n[%d] %s", bkgno, oormsg); + else if (isatty (fileno (stdin))) + eprintf ("%s\n", oormsg); + else + cl_error (E_UERR, oormsg); + } + + if (!(pp->p_type & PT_LIST)) { + /* update param with new value. + */ + if (cldebug) { + eprintf ("changing `%s.p_val' to ", pp->p_name); + fprop (stderr, &o); + eprintf ("\n"); + } + + pushop (&o); + paramset (pp, FN_VALUE); + pp->p_flags |= P_QUERY; + } + + pushop (&o); + + if (arrflag && query_status != NULL && *ip != '\0') { + /* If we have an array assign values until something + * is used up or until we hit any error. + */ + n_ele = 1; + forever { + if (n_ele >= max_ele) /* End of array. */ + break; + ip = nextstr(&abuf, stdin); + + if (ip == NULL) /* End of query line. */ + break; + + if (ip == (char *) ERR) { /* Error on query line. */ + eprintf("Error loading array value.\n"); + break; + } + + if (ip != undefval) { + o = makeop (ip, bastype); + if ( ! inrange (pp, &o) ) { /* Not in range. */ + eprintf("Array value outside range.\n"); + break; + } + + offset++; /* Next element in array. */ + poffset (offset); + + pushop (&o); + paramset (pp, FN_VALUE); + } else + offset++; + + n_ele++; + } + } + +} + + +/* NEXTSTR -- Get the next string in a prompt. + */ +char * +nextstr ( + char **pbuf, + FILE *fp +) +{ + char *p, *nxtchr(); + static char tbuf[SZ_LINE]; + char quote; + int cnt; + + p = *pbuf; + + /* Skip white space. */ + while ( *p == ' ' || *p == '\t' || *p =='\n') + p = nxtchr(p, fp); + + /* Reached end? */ + if (*p == '\0') { + *pbuf = p; + return (NULL); + } + + quote = '\0'; + cnt = 0; + + /* Quoted string. */ + if (*p == '\'' || *p == '"') { + quote = *p; + p = nxtchr (p, fp); + + while (*p != quote) { + + if (p == '\0' || cnt >= SZ_LINE) + return ( (char *) ERR); + + else { + tbuf[cnt++] = *p; + p = nxtchr(p, fp); + } + } + /* Skip quote. */ + p = nxtchr (p, fp); + + } else { + /* Unquoted string. */ + while (*p != ' ' && *p != '\t' && *p != '\n' && + *p != '\0' && *p != ',') { + + if (cnt >= SZ_LINE) + return ( (char *) ERR ); + + tbuf[cnt++] = *p; + p = nxtchr (p, fp); + } + } + tbuf[cnt] = '\0'; + + /* Skip any white-space following. */ + while (*p == ' ' || *p == '\t' || *p == '\n') + p = nxtchr(p, fp); + + if (*p != ',' && *p != '\0') + return ( (char *) ERR); + + /* Skip delimiter. */ + if (*p == ',') + p = nxtchr(p, fp); + + *pbuf = p; + if (cnt == 0) { + /* Return a quoted null string, otherwise the field was skipped. */ + if (quote != '\0') + return (tbuf); + else + return (undefval); + } else + return (tbuf); +} + + +/* NXTCHR -- Get a pointer to the next char, reading the next line if necessary. + */ +char * +nxtchr ( + char *p, + FILE *fp +) +{ + /* P may point to within readbuf on return, so it had better be + * static. + */ + static char readbuf[SZ_LINE]; + + if (*p) + p++; +start: + if (*p == '\\') { + if (*(p+1) == '\n') { + if (fgets (readbuf, SZ_LINE, fp) == NULL) + /* We assume that the newline is always followed by a + * null in return from fgets. + */ + return (p+2); + else { + p = readbuf; + goto start; + } + } + } + + return (p); +} + + +/* PQUERY -- Print the query message. + */ +void +pquery ( + register struct param *pp, + FILE *fp +) +{ + struct operand o; + int offset, arrflag; + + arrflag = pp->p_type & PT_ARRAY; + + fprintf (fp, *pp->p_prompt == '\0' ? pp->p_name : pp->p_prompt); + + /* Show the ranges if they are defined and this is a parameter + * type that has ranges. + */ + if (range_check (pp)) { + fprintf (fp, " ("); + if (!(pp->p_flags & (P_IMIN|P_UMIN))) { + paramget (pp, FN_MIN); + o = popop(); + fprop (fp, &o); + } + if ((pp->p_type & OT_BASIC) != OT_STRING) + fprintf (fp, ":"); + if (!(pp->p_flags & (P_IMAX|P_UMAX))) { + paramget (pp, FN_MAX); + o = popop(); + fprop (fp, &o); + } + fputc (')', fp); + } + + /* Print the array indices. We get the offset and convert back + * to the indices. This works regardless of the offset mode. + */ + if (arrflag) { + int dim, d, rem, temp; + short *len, *off; + + offset = getoffset (pp); + poffset (offset); /* Restore stack for later reference */ + + dim = pp->p_val.v_a->a_dim; + len = &(pp->p_val.v_a->a_len) ; + off = &(pp->p_val.v_a->a_off) ; + + fputc ('[', fp); + temp = offset; + for (d=0; d0) + fputc (',', fp); + + rem = (temp % *len) + *off; + fprintf (fp, "%d",rem); + temp = temp / *len; + len = len + 2; + off = off + 2; + } + fputc (']', fp); + } + + /* Set o to the current value of the parameter. List files do + * not keep a value in core, however, and we certainly do not want + * to read the list to get one. + */ + if (pp->p_type & PT_LIST) + setopundef (&o); + else { + paramget (pp, FN_VALUE); + o = popop(); + + /* Restore offset on stack if array. */ + if (arrflag) { + poffset (offset); + } + } + + /* Print current value if not undefined. Ok if just indefinite. + */ + if (!opundef (&o)) { + if ((o.o_type & OT_BASIC) != OT_STRING || *(o.o_val.v_s) != '\0') { + fprintf (fp, " ("); + fprop (fp, &o); + fputc (')', fp); + } + } + fprintf (fp, ": "); + fflush (fp); +} + + +/* BKG_QUERY -- Send the "waiting for parameter input" to the user terminal, + * and loop until the background query response file is readable. + * This happens when the user responds to the query by executing "service". + * Check frequently in the beginning, gradually lengthening the sleep periods + * so that we do not hog the machine if the user is out to lunch. Timeout + * after a suitable interval if no response. + */ +char * +bkg_query ( + char *obuf, /* same calling sequence as 'fgets' */ + int maxch, + register struct param *pp +) +{ + char bqfile[SZ_PATHNAME], qrfile[SZ_PATHNAME]; + int waitime, delay; + char *envget(), *fgets_status; + FILE *fp, *in; + + if (notify()) + eprintf ("\n[%d] stopped waiting for parameter input\n", bkgno); + get_bkgqfiles (bkgno, ppid, bqfile, qrfile); + + /* Get names of the query and query response files and open the query + * file to receive the query. Post query request on the user terminal. + * If an old query response file happens to be lying about, delete it. + */ + c_delete (bqfile); + if ((fp = fopen (bqfile, "w")) == NULL) + cl_error (E_UERR, "Cannot create file `%s' for query", bqfile); + c_delete (qrfile); + + /* Print the query prompt into the background query request file. + */ + pquery (pp, fp); + fclose (fp); + + waitime = 0; + delay = INIT_DELAY; + + /* Loop until the query response file is readable. Sleep for + * progressively longer intervals if no response, then timeout. + */ + do { + if (waitime > BKQ_TIMEOUT) { + c_delete (bqfile); + cl_error (E_UERR, "Timeout on query"); + } else { + delay = (delay *= DELAY_MULT) > MAXDELAY ? MAXDELAY : delay; + c_tsleep (delay); + waitime += delay; + } + } while (c_access (qrfile,0,0) == NO); + + if ((in = fopen (qrfile, "r")) == NULL) + cl_error (E_UERR, "cannot open query response file"); + + fgets_status = fgets (obuf, maxch, in); + fclose (in); + c_delete (qrfile); + + return (fgets_status); +} + + +/* SERVICE_BKGQUERY -- Called by the user to service a background query. + * We must open the background query file for the indicated task and type + * out the prompt therein for the user. The user's response in then placed + * in the query response file, we delete the original query file, and we + * are done. When the bkg job wakes up it will read the response file and + * (assuming there are no errors) continue on. + */ +void +service_bkgquery ( + int bkgno /* ordinal of job requiring service */ +) +{ + register int ch; + char bqfile[SZ_PATHNAME], qrfile[SZ_PATHNAME]; + char qrtemp[SZ_PATHNAME]; + char response[SZ_LINE+1]; + FILE *fp; + + if (bkg_jobactive (bkgno) == NO) + cl_error (E_UERR, "No such job"); + else + get_bkgqfiles (bkgno, c_getpid(), bqfile, qrfile); + c_mktemp ("uparm$QR", qrtemp, SZ_PATHNAME); + + if ((fp = fopen (bqfile, "r")) == NULL) + cl_error (E_UERR, "No query is pending for bkg job [%d]", bkgno); + + /* Copy query file verbatim to the user's terminal. The last line + * will not have a newline, but that is ok here. + */ + while ((ch = fgetc(fp)) != EOF) + putchar (ch); + fflush (stdout); + + /* Get user's response and write into query response file. + * We write the response first into a temp file and then rename the + * temp file to eliminate the chance that the bkg job will try to + * open and read the response file before the data has all been + * written into it (happens on systems that do not lock files + * opened by another process for writing). + */ + c_delete (qrtemp); + fgets (response, SZ_LINE, stdin); + if ((fp = fopen (qrtemp, "w")) == NULL) + cl_error (E_UERR, "Cannot open `%s' to respond to query", qrtemp); + fputs (response, fp); + fclose (fp); + c_rename (qrtemp, qrfile); + + /* Do not delete the query file until we successfully respond to + * the query (in case of an abort). + */ + c_delete (bqfile); +} + + +/* GET_BKGQFILES -- Get the name of a background query file. This routine + * aborts if the directory uparm$ is not defined. Since we have two processes + * communicating via files, we must have a fixed directory both processes + * expect to find the files. We assume that the user does not start a bkg + * job and then change uparm$ in the foreground cl. + */ +void +get_bkgqfiles ( + int bkgno, + int pid, + char *bkg_query_file, + char *query_response_file +) +{ + int filecode; + char *envget(); + + if (envget (UPARM) == NULL) + cl_error (E_UERR, + "Logical directory 'uparm$' not defined, cannot query"); + + filecode = bkgno * 10000 + (pid % 10000); + sprintf (bkg_query_file, "%sBQF%d", envget(UPARM), filecode); + sprintf (query_response_file, "%sBQR%d", envget(UPARM), filecode); +} + + +/* INRANGE -- Check whether operand *op is in range, that is, that its o_val + * field is within the limits defined by the p_min/max fields in param *pp. + * Return YES if it is in range, else NO. In the case of filenames, also + * check that the PT_FXX access attributes are true. Also, filenames are + * considered out of range is they are indefinite (unlike other types; see + * below). + * The basic types for the operand and the parameter must agree. + * Always return YES for types that do not have ranges (only ints, reals, + * and filenames have ranges), when min > max, or when op is INDEF. + * Always return NO if op is UNDEFined. + * This routine uses binexp() and thus the operand stack. + */ +int +inrange ( + register struct param *pp, + register struct operand *op +) +{ + register int fulltype, bastype; + struct operand omin, test; + + fulltype = pp->p_type; + bastype = fulltype & OT_BASIC; + + /* If the operand is undefined, it is out of range. Indefinite is + * inrange for int and real type params. + */ + if (opundef (op)) + return (NO); + if (opindef (op) && bastype & (OT_INT|OT_REAL)) + return (YES); + + /* If range checking is disabled, and the parameter value is defined, + * it is in range. + */ + if (range_check (pp) == 0) + return (YES); + + if (fulltype & PT_FILNAM) { + /* check any access attributes given. + */ + char *filnam = op->o_val.v_s; + if (opindef (op)) + return (NO); + + if ((fulltype & PT_FER) && c_access (filnam, READ_ONLY, 0) == NO) + cl_error (E_UERR, "File `%s' is not readable", filnam); + if ((fulltype & PT_FEW) && c_access (filnam, WRITE_ONLY, 0) == NO) + cl_error (E_UERR, "File `%s' is not writable", filnam); + if ((fulltype & PT_FNOE) && c_access (filnam,0,0) == YES) + cl_error (E_UERR, "File `%s' exists", filnam); + + if ((fulltype & PT_FTXT) && c_access (filnam, 0, TEXT_FILE) == NO) + cl_error (E_UERR, "File `%s' is not a text file", filnam); + if ((fulltype & PT_FBIN) && c_access (filnam, 0, TEXT_FILE) == YES) + cl_error (E_UERR, "File `%s' is not a binary file", filnam); + } + + /* If the param is string valued and the legal values are enumerated, + * any minimum match abbreviation is considered in range. Return the + * FULL string in the operand structure. The legal values of an + * enumerated string type parameter are given in the min field as a + * string of the form "val|val|val". Embedded whitespace is not + * permitted. + */ + if (bastype == OT_STRING && !(pp->p_flags & P_UMIN)) { + char *s, *delim, *match; + char *val, *index(); + int n; + + paramget (pp, FN_MIN); + omin = popop(); + if (omin.o_type != OT_STRING || op->o_type != OT_STRING) + return (NO); + + val = op->o_val.v_s; + n = strlen (val); + match = NULL; + + for (delim = s = omin.o_val.v_s; delim && *s; s=delim+1) { + delim = index (s, '|'); + if (delim) + *delim = '\0'; + if (strncmp (s, val, n) == 0) { + if (match) { + eprintf ("ambiguous abbreviation '%s'\n", val); + return (NO); + } else + match = s; + } + } + + if (match != NULL) + op->o_val.v_s = comdstr (match); + return (match != NULL); + } + + /* Check the minimum value, if one is given. + */ + if (!(pp->p_flags & (P_IMIN|P_UMIN))) { + pushop (op); + paramget (pp, FN_MIN); + binexp (OP_GE); /* op >= p_min? */ + test = popop(); + if (!test.o_val.v_i) /* if (false) op out of range */ + return (NO); + } + + /* Check the maximum value, if one is given. + */ + if (!(pp->p_flags & (P_IMAX|P_UMAX))) { + pushop (op); + paramget (pp, FN_MAX); + binexp (OP_LE); /* op <= p_max? */ + test = popop(); + if (!test.o_val.v_i) /* if (false) op out of range */ + return (NO); + } + return (YES); +} + + +/* RANGE_CHECK -- Determine if range checking is in effect. Range checking + * is only employed for int, real, string (enumerated) and filename params. + * If both the min and max fields are set, but max is less than min, checking + * is disabled. + */ +int +range_check ( + struct param *pp +) +{ + int fulltype, bastype; + struct operand test, omin, omax; + + fulltype = pp->p_type; + bastype = fulltype & OT_BASIC; + + /* No range checking for bools, or when range values are undefined + * or indefinite. + */ + if (bastype == OT_BOOL || + fulltype & (PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY|PT_PSET)) + return (NO); + if (pp->p_flags & (P_IMIN|P_UMIN) && pp->p_flags & (P_IMAX|P_UMAX)) + return (NO); + + /* Range checking is disabled if the max value is set lower than + * the min value. + */ + if (!(pp->p_flags & (P_UMIN|P_IMIN|P_UMAX|P_IMAX))) { + omax.o_type = omin.o_type = bastype; + omin.o_val = pp->p_min; + omax.o_val = pp->p_max; + pushop (&omin); + pushop (&omax); + binexp (OP_GT); /* p_min > p_max? */ + test = popop(); + if (test.o_val.v_i) /* if (true) artificially pass */ + return (NO); + } + + return (YES); /* should range check */ +} + + +/* SETCLMODES -- Set up the cl mode reference pointers to point to their + * special-function params. tp is firstask. Set the pointers to NULL if the + * parameter is not found. Called once by login() after the cl's pfile has + * been read in. + */ +void +setclmodes ( + struct task *tp +) +{ + register struct param *pp; + register char *name; + int bastype; + + clabbrev = clmenus = clshowtype = clkeeplog = cllexmodes = cllogfile = + clnotify = clecho = NULL; + + for (pp = tp->t_pfp->pf_pp; pp != NULL; pp = pp->p_np) { + + /* Set "CL parameter" bit to aid checking in paramset(). + * Also, parse any parameters that need it. (This is necessary + * to get the current values of `logmode' when running in bkg.) + */ + pp->p_flags |= P_CL; + parse_clmodes (pp, &pp->p_valo); + + /* Limit the strcmp's to only those params with the right + * basic time to speed this up a bit. Be careful when adding + * new entries that they go into the right type. + * For now, at least, ignore all list params. + */ + if (pp->p_type & PT_LIST) + continue; + + bastype = pp->p_type & OT_BASIC; + name = pp->p_name; + if (bastype == OT_STRING) { + if (!strcmp (name, "mode")) + firstask->t_modep = pp; + else if (!strcmp (name, "logfile")) + cllogfile = pp; + } else if (bastype == OT_BOOL) { + if (!strcmp (name, "menus")) + clmenus = pp; + else if (!strcmp (name, "showtype")) + clshowtype = pp; + else if (!strcmp (name, "keeplog")) + clkeeplog = pp; + else if (!strcmp (name, "lexmodes")) + cllexmodes = pp; + else if (!strcmp (name, "abbreviate")) + clabbrev = pp; + else if (!strcmp (name, "notify")) + clnotify = pp; + else if (!strcmp (name, "echo")) + clecho = pp; + } + } +} + + +#define NEXT_TOKEN while (*ip == ' ' || *ip == '\t' || *ip == '\n') ip++; \ + if (!*ip) break; +#define NEXT_WHITE while (*ip != ' ' && *ip != '\t' && *ip != '\0') ip++; + +/* PARSE_CLMODES -- Called whenever a CL parameter is set at runtime. A + * few of the CL parameters need to be parsed and internal variables set + * appropriately. Tokens in the parameter strings are white-space + * delimited. + */ +void +parse_clmodes ( + struct param *pp, + struct operand *newval +) +{ + register char *name, *ip; + + name = pp->p_name; + + if (!strcmp (name, "logmode")) { + ip = newval->o_val.v_s; + while (*ip) { + NEXT_TOKEN; + + /* Check the next token; only a few matching characters + * are needed. Default values are set elsewhere, so we + * check for all possibilities here. + */ + if (strncmp (ip, "commands", 5) == 0) + cllogmode |= LOG_COMMANDS; + else if (strncmp (ip, "nocommands", 5) == 0) + cllogmode &= ~LOG_COMMANDS; + + else if (strncmp (ip, "background", 5) == 0) + cllogmode |= LOG_BACKGROUND; + else if (strncmp (ip, "nobackground", 5) == 0) + cllogmode &= ~LOG_BACKGROUND; + + else if (strncmp (ip, "errors", 5) == 0) + cllogmode |= LOG_ERRORS; + else if (strncmp (ip, "noerrors", 5) == 0) + cllogmode &= ~LOG_ERRORS; + + else if (strncmp (ip, "trace", 5) == 0) + cllogmode |= LOG_TRACE; + else if (strncmp (ip, "notrace", 5) == 0) + cllogmode &= ~LOG_TRACE; + + else if (*ip != '\0') + eprintf ("unrecognized logging set-option `%s'\n", ip); + + NEXT_WHITE; + } + + } else if (!strcmp (name, "logfile")) { + reset_logfile(); + + } else if (!strcmp (name, "epinit")) { + ip = newval->o_val.v_s; + while (*ip) { + NEXT_TOKEN; + + if (strncmp (ip, "standout", 5) == 0) + ep_standout = YES; + else if (strncmp (ip, "nostandout", 5) == 0) + ep_standout = NO; + else if (strncmp (ip, "showall", 5) == 0) + ep_showall = YES; + else if (strncmp (ip, "noshowall", 5) == 0) + ep_showall = NO; + else if (*ip != '\0') + eprintf ("unrecognized eparam set-option `%s'\n", ip); + + NEXT_WHITE; + } + + } else if (!strcmp (name, "ehinit")) { + ip = newval->o_val.v_s; + while (*ip) { + NEXT_TOKEN; + + if (strncmp (ip, "verify", 5) == 0) + eh_verify = YES; + else if (strncmp (ip, "noverify", 5) == 0) + eh_verify = NO; + else if (strncmp (ip, "standout", 5) == 0) + eh_standout = YES; + else if (strncmp (ip, "nostandout", 5) == 0) + eh_standout = NO; + else if (strncmp (ip, "bol", 3) == 0) + eh_bol = YES; + else if (strncmp (ip, "eol", 3) == 0) + eh_bol = NO; + else if (*ip != '\0') + eprintf ("unrecognized ehistory set-option `%s'\n", ip); + + NEXT_WHITE; + } + + } else if (!strcmp (name, "szprcache")) { + /* Change the size of the process cache. + */ + pr_setcache (newval->o_val.v_i); + + } else if (!strcmp (name, "mode")) { + /* Menu mode is not permitted at the CL level. + */ + char *index(); + + if (index (newval->o_val.v_s, 'm') != NULL) + cl_error (E_UERR, + "menu mode is permitted only for packages and tasks"); + } +} + + +/* ABBREV -- Determine if abbreviations are allowed. Abbreviations are + * only allowed if the currentask is interactive (or batch), or if the + * currentask is a builtin and the previous task is interactive (or batch), + * regardless of value of clabbrev parameter. + */ +int +abbrev (void) +{ + /* Enable abbreviations everywhere for now. + int cflags = currentask->t_flags; + int pflags = prevtask->t_flags; + + if (clabbrev == NULL) + return (NO); + if ((clabbrev->p_valo.o_type & (OT_UNDEF|OT_INDEF)) || + !clabbrev->p_valo.o_val.v_i) + return (NO); + + if (cflags & (T_INTERACTIVE|T_BATCH)) + return (YES); + if ((cflags & T_BUILTIN) && (pflags & (T_INTERACTIVE|T_BATCH))) + return (YES); + + return (NO); + */ + + return (YES); +} + +/* POFFSET--push an offset in an array for a later reference. + */ +void +poffset (int off) +{ + n_indexes++; + push (off); + offsetmode(1); +} diff --git a/pkg/cl/opcodes.c b/pkg/cl/opcodes.c new file mode 100644 index 00000000..7cda90ab --- /dev/null +++ b/pkg/cl/opcodes.c @@ -0,0 +1,1447 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "config.h" +#include "mem.h" +#include "operand.h" +#include "param.h" +#include "grammar.h" +#include "task.h" +#include "opcodes.h" +#include "errs.h" +#include "construct.h" +#include "proto.h" + + +/* + * OPCODES -- This is the instruction set that forms the internal language of + * the CL. The runtime interpreter (in runtime.c) executes these functions + * as they are discovered in the compiled code. The code is generated + * incrementally as the grammar is recognized in grammar.y by calls to + * compile(). The argument, argp, if needed, is the true addr of the start + * of the instruction arguments. + * If anything goes wrong, error() is called but DOES NOT RETURN; see errs.c. + * + * Comments indicate stack usage. expected operands are before the `.' + * (rightmost being on "top" of stack), resulting operands are after. + * + * At the end of this file is the opcode jumptable. The order of the entries + * must agree with the definitions of the opcode constants in operand.h. + * see runtime.c. + */ + +extern int cldebug; +extern char *nullstr; +int binpipe; /* last pipe binary or text ? */ +char *comdstr(); +extern struct param *ppfind(); /* search task psets for param */ + +void +o_undefined (void) +{ + cl_error (E_IERR, e_uopcode, 0); +} + +/* . + * Assign the top operand to the named parameter. Also, make the type of the + * fake parameter the same as the type of the operand. + */ +void +o_absargset ( + memel *argp +) +{ + char *argname = (char *) argp; + char *pk, *t, *p, *f; + struct pfile *pfp; + struct param *pp; + + pfp = newtask->t_pfp; + if (pfp->pf_flags & PF_FAKE) { + /* use full argname and always assign to value field. + */ + struct operand o; + int string_len; + o = popop(); + if ((o.o_type & OT_BASIC) == OT_STRING) + string_len = strlen (o.o_val.v_s); + pp = newfakeparam (pfp, argname, 0, o.o_type, string_len); + pushop (&o); + f = argname; + *f = FN_NULL; + + } else { + breakout (argname, &pk, &t, &p, &f); + if (*pk) + cl_error (E_UERR, e_simplep, p); + pp = ppfind (pfp, t, p, 0, NO); + if (pp == NULL) + cl_error (E_UERR, e_pnonexist, p); + if ((XINT)pp == ERR) + cl_error (E_UERR, e_pambig, p, pfp->pf_ltp->lt_lname); + } + + paramset (pp, *f); + if (pp->p_type & PT_PSET) + psetreload (pfp, pp); + pp->p_flags |= P_CLSET; +} + +/* . + */ +void +o_add (void) +{ + binop (OP_ADD); +} + +/* . + */ +void +o_addassign ( + memel *argp +) +{ + /* order of operands will be incorrect. + * strictly speaking, only strings are not commutative but we need + * to pop both operands anyway to check. + */ + char *pname = (char *) argp; + char *pk, *t, *p, *f; + struct param *pp; + struct operand o1, o2; + + breakout (pname, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + validparamget (pp, *f); + o1 = popop(); + o2 = popop(); + + if ((o2.o_type & OT_BASIC) == OT_STRING) { + /* copy o2 onto dictionary to avoid overwriting it on stack + * when o1 is pushed. we can get by with not worrying about o1 + * as long as whatever code copies the string works when the + * strings overlap. + */ + XINT oldtopd = topd; + char *s2 = memneed (btoi (strlen (o2.o_val.v_s) + 1)); + strcpy (s2, o2.o_val.v_s); + o2.o_val.v_s = s2; + pushop (&o1); + pushop (&o2); + topd = oldtopd; /* discard temp string area */ + + } else { + pushop (&o1); + pushop (&o2); + } + + binop (OP_ADD); + paramset (pp, *f); + pp->p_flags |= P_SET; +} + +/* . + * includes stdout as well as stderr. + */ +void +o_allappend (void) +{ + struct operand o; + char *fname, *mode; + + opcast (OT_STRING); + o = popop(); + fname = o.o_val.v_s; + + if (newtask->t_flags & T_FOREIGN && + newtask->t_stdout == stdout && newtask->t_stderr == stderr) { + + /* If foreign task and i/o has not already been redirected by + * the parent, let ZOSCMD open the spool file. + */ + newtask->ft_out = newtask->ft_err = comdstr (fname); + newtask->t_flags |= T_APPEND; + + } else { + mode = (newtask->t_flags & T_STDOUTB) ? "ab" : "a"; + + if ((newtask->t_stdout = fopen (fname, mode)) == NULL) + cl_error (E_UERR, e_appopen, fname); + + newtask->t_stderr = newtask->t_stdout; + newtask->t_flags |= (T_MYOUT|T_MYERR); + } +} + + +/* . + * redirect everything, including the stderr channel. + */ +void +o_allredir (void) +{ + struct operand o; + char *fname, *mode; + + opcast (OT_STRING); + o = popop(); + fname = (o.o_val.v_s); + + if (newtask->t_flags & T_FOREIGN && + newtask->t_stdout == stdout && newtask->t_stderr == stderr) { + + /* If foreign task and i/o has not already been redirected by + * the parent, let ZOSCMD open the spool file. + */ + newtask->ft_out = newtask->ft_err = comdstr (fname); + + } else { + mode = (newtask->t_flags & T_STDOUTB) ? "wb" : "w"; + + if ((newtask->t_stderr = fopen (fname, mode)) == NULL) + cl_error (E_UERR, e_wopen, fname); + + newtask->t_stdout = newtask->t_stderr; + newtask->t_flags |= (T_MYOUT|T_MYERR); + } +} + + +/* . + */ +void +o_and (void) +{ + binexp (OP_AND); +} + +/* . + */ +void +o_append (void) +{ + struct operand o; + char *fname, *mode; + + opcast (OT_STRING); + o = popop(); + fname = (o.o_val.v_s); + + if (newtask->t_flags & T_FOREIGN && newtask->t_stdout == stdout) { + /* If foreign task let ZOSCMD open the spool file. + */ + newtask->ft_out = comdstr (fname); + newtask->t_flags |= T_APPEND; + } else { + mode = (newtask->t_flags & T_STDOUTB) ? "ab" : "a"; + + if ((newtask->t_stdout = fopen (fname, mode)) == NULL) + cl_error (E_UERR, e_appopen, fname); + + newtask->t_flags |= T_MYOUT; + } +} + + +/* . + */ +void +o_assign ( + memel *argp +) +{ + char *pname = (char *) argp; + char *pk, *t, *p, *f; + struct param *pp; + + breakout (pname, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + paramset (pp, *f); + pp->p_flags |= P_SET; +} + +/* . + * branch if false (or INDEF). + */ +void +o_biff ( + memel *argp +) +{ + extern XINT pc; + struct operand o; + + opcast (OT_BOOL); + o = popop(); + if (!o.o_val.v_i || opindef (&o)) + pc += (int)*argp; +} + +/* . + * arrange to start a new task. set newtask. + * see runtime.c + */ +void +o_call ( + memel *argp +) +{ + callnewtask ((char *) argp); +} + +/* . <- op> + */ +void +o_chsign (void) +{ + unop (OP_MINUS); +} + +/* // + * string concatenation + */ +void +o_concat (void) +{ + binop (OP_CONCAT); +} + +/* . + */ +void +o_div (void) +{ + binop (OP_DIV); +} + +void +o_doend (void) +{ +} + +/* . + */ +void +o_divassign ( + memel *argp +) +{ + char *pname = (char *) argp; + char *pk, *t, *p, *f; + struct param *pp; + struct operand o1, o2; + + breakout (pname, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + + validparamget (pp, *f); /* get param value on stack */ + o1 = popop(); /* swap operands */ + o2 = popop(); + pushop (&o1); + pushop (&o2); + binop (OP_DIV); /* perform the division */ + paramset (pp, *f); + pp->p_flags |= P_SET; +} + +/* . + */ +void +o_catassign ( + memel *argp +) +{ + char *pname = (char *) argp; + char *pk, *t, *p, *f; + char s1[1024+1]; + struct operand o1, o2; + struct param *pp; + + breakout (pname, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + paramget (pp, *f); + + /* If param value is undefined merely assign into it, otherwise + * concatenate operand to current value. + */ + o1 = popop(); + if (!opundef(&o1)) { + /* Must copy string value off of operand stack or the next + * pushop below will reuse the space! + */ + o2 = popop(); + strncpy (s1, o2.o_val.v_s, 1024); + s1[1024] = EOS; + o2.o_val.v_s = s1; + + pushop (&o1); + pushop (&o2); + binop (OP_CONCAT); + } + + paramset (pp, *f); + pp->p_flags |= P_SET; +} + +/* . + */ +void +o_eq (void) +{ + binexp (OP_EQ); +} + +/* run the newtask. see exec.c. + */ +void +o_exec (void) +{ + execnewtask (); +} + +/* . op2> + */ +void +o_ge (void) +{ + binexp (OP_GE); +} + +/* unconditional goto. + * *argp is the SIGNED increment to be added to pc. + */ +void +o_dogoto ( + memel *argp +) +{ + extern XINT pc; + pc += (int)*argp; + if (pc >= STACKSIZ) + cl_error (E_IERR, "pc set wildly to %d during goto", pc); +} + +/* . op2> + */ +void +o_gt (void) +{ + binexp (OP_GT); +} + +/* . + * if argument to which we are assigning is a simple string or filename (or + * list, since assigning to a list sets a filename too), set it to o_val.v_s, + * else use o_val.v_s as the name of a parameter and use its value as the name + * of the variable, that is, do an indirect through o_val.v_s. + * compiled when the parser sees a simple identifier, not in an expression. + * this avoids quotes around simple strings and filenames. + * if the parameter is to be fake, make it type string and do not do the + * indirection. + */ +void +o_indirabsset ( + memel *argp +) +{ + char *argname = (char *) argp; + char *pk, *t, *p, *f; + struct pfile *pfp; + struct param *pp; + int type, string_len; + + pfp = newtask->t_pfp; + if (pfp->pf_flags & PF_FAKE) { + struct operand o; + o = popop(); + string_len = strlen (o.o_val.v_s); + pp = newfakeparam (pfp, argname, 0, OT_STRING, string_len); + f = argname; + *f = FN_NULL; + pushop (&o); + + } else { + breakout (argname, &pk, &t, &p, &f); + if (*pk) + cl_error (E_UERR, e_simplep, p); + pp = ppfind (pfp, t, p, 0, NO); + if (pp == NULL) + cl_error (E_UERR, e_pnonexist, p); + if ((XINT)pp == ERR) + cl_error (E_UERR, e_pambig, p, pfp->pf_ltp->lt_lname); + } + + /* lone identifiers are treated as strings, rather than variables, + * if the corresponding parameter is a simple string, filename or list. + * note that fakeparams are made as strings. + */ + type = pp->p_type; + if (type & (PT_FILNAM|PT_LIST|PT_PSET)) { + struct operand o; + o = popop(); + pushop (&o); + } else if ((type & OT_BASIC) != OT_STRING || + type & (PT_STRUCT|PT_IMCUR|PT_GCUR|PT_UKEY)) { + + opindir(); /* replace top op with value of o_val.v_s */ + } + + paramset (pp, *f); + if (pp->p_type & PT_PSET) + psetreload (pfp, pp); + pp->p_flags |= P_CLSET; +} + +/* . + * if argument to which we are assigning is a simple string or filename (or + * list, since assigning to a list sets a filename too), set it to o_val.v_s, + * else use o_val.v_s as the name of a parameter and use its value as the name + * of the variable, that is, do an indirect through o_val.v_s. + * compiled when the parser sees a simple identifier, not in an expression. + * this avoids quotes around simple strings and filenames. + */ +void +o_indirposset ( + memel *argp +) +{ + int pos = (int) *argp; + struct pfile *pfp; + struct param *pp; + int type, string_len; + + pfp = newtask->t_pfp; + if (pfp->pf_flags & PF_FAKE) { + struct operand o; + o = popop(); + string_len = strlen (o.o_val.v_s); + pp = newfakeparam (pfp, (char *) NULL, pos, OT_STRING, string_len); + pushop (&o); + } else { + pp = paramfind (pfp, (char *) NULL, pos, NO); + if (pp == NULL) + cl_error (E_UERR, e_posargs, newtask->t_ltp->lt_lname); + } + + /* lone identifiers are treated as strings, rather than variables, + * if the corresponding parameter is a simple string, filename or list. + * note that fakeparams are made as strings. + */ + type = pp->p_type; + if (type & (PT_FILNAM|PT_LIST|PT_PSET)) { + struct operand o; + o = popop(); + pushop (&o); + } else if ((type & OT_BASIC) != OT_STRING || + type & (PT_STRUCT|PT_IMCUR|PT_GCUR|PT_UKEY)) { + + opindir(); /* replace top op with value of o_val.v_s */ + } + + paramset (pp, FN_NULL); + pfp->pf_n++; + pp->p_flags |= P_CLSET; +} + +/* Increment the loop counters for an implicit loop. + */ +void +o_indxincr ( + memel *argp +) +{ + int i; + i = 0; + while (i < n_oarr) { + if (oarr_curr[i] < oarr_end[i] ) { + oarr_curr[i] ++; + i_oarr = 0; + pc += argp[0]; /* Branch to beginning of statement. */ + return; + } else { + oarr_curr[i] = oarr_beg[i]; + i++; + } + } + + /* Finished loop, branch around stored data. */ + pc += argp[1]; + + /* Clear flag for next implicit loop. */ + imloopset = 0; +} + + +/* . + * given the name of a parameter, print it on t_out, the task pipe channel. + */ +void +o_inspect ( + memel *argp +) +{ + char *pname = (char *) argp; + char *pk, *t, *p, *f; + struct param *pp; + struct operand o; + + breakout (pname, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + + if (*f == FN_NULL && (pp->p_type & PT_LIST)) { + /* Hitting EOF from a list is ok during an inspect stmt so + * avoid using paramget() with its EOF error. + * readlist() may set P_LEOF. + */ + o = readlist (pp); + if ((pp->p_flags & P_LEOF) || inrange (pp, &o)) + pushop (&o); + else + query (pp); + } else + validparamget (pp, *f); + + o = popop(); + + if (cldebug && (o.o_type & OT_BASIC) == OT_STRING) + eprintf ("Inspect--%s\n", o.o_val.v_s); + + prop (&o); + tprintf ("\n"); +} + + +/* [ ... ] . + * intrinsic functions, like sin, cos, mod, etc. + * argp is the name of the function to run and the top operand (we guarantee + * at least one) is the number of remaining operands to be used. + * all the defines are in operand.h. the function names and running them is + * done by intrfunc() in gram.c. + */ +void +o_intrinsic ( + memel *argp +) +{ + char *funcname = (char *) argp; + struct operand o; + int nargs; + + o = popop(); + nargs = o.o_val.v_i; + + intrfunc (funcname, nargs); +} + +/* . + */ +void +o_le (void) +{ + binexp (OP_LE); +} + +/* . + */ +void +o_lt (void) +{ + binexp (OP_LT); +} + +/* . + */ +void +o_mul (void) +{ + binop (OP_MUL); +} + +/* . + */ +void +o_mulassign ( + memel *argp +) +{ + char *pname = (char *) argp; + char *pk, *t, *p, *f; + struct param *pp; + + breakout (pname, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + + validparamget (pp, *f); + binop (OP_MUL); + paramset (pp, *f); + pp->p_flags |= P_SET; +} + +/* . + */ +void +o_ne (void) +{ + binexp (OP_NE); +} + +/* . + */ +void +o_not (void) +{ + unexp (OP_NOT); +} + +/* . + */ +void +o_or (void) +{ + binexp (OP_OR); +} + + +/* OSESC -- Send a command to the host system. Command is a string pointed + * to by argp. Try to run it so its stdout and stderr will go to out t_stdout + * and t_stderr of the current task. + */ +void +o_osesc ( + memel *argp +) +{ + char *command = (char *)argp; + + clsystem (command, currentask->t_stdout, currentask->t_stderr); +} + + +/* . + */ +void +o_posargset ( + memel *argp +) +{ + int pos = (int) *argp; + struct pfile *pfp; + struct param *pp; + struct operand o; + int string_len; + + pfp = newtask->t_pfp; + + if (pos < 0) { + /* Lone comma in arg list, merely bump nargs counter */ + pfp->pf_n++; + return; + } + + if (pfp->pf_flags & PF_FAKE) { + o = popop(); + if ((o.o_type & OT_BASIC) == OT_STRING) + string_len = strlen (o.o_val.v_s); + pp = newfakeparam (pfp, (char *) NULL, pos, o.o_type, string_len); + pushop (&o); + } else { + pp = paramfind (pfp, (char *) NULL, pos, NO); + if (pp == NULL) + cl_error (E_UERR, e_posargs, newtask->t_ltp->lt_lname); + } + + paramset (pp, FN_NULL); + pfp->pf_n++; + pp->p_flags |= P_CLSET; +} + + +/* . + */ +void +o_dopow (void) +{ + + binop (OP_POW); +} + +/* ... . + * Do the print task. First op on stack is number of operands to follow. + * Next one is the name of the destination parameter, rest are values to + * be printed. + */ +void +o_doprint (void) +{ + /* This is not used -- print is imp. as a builtin task. + struct operand o; + + o = popop(); + print (o.o_val.v_i - 1); + */ +} + +/* . + * used to print an operand on the stack. not to be confused with doprint. + */ +void +o_immed (void) +{ + struct operand o; + + o = popop(); + prop (&o); + tprintf ("\n"); +} + +/* . + * The "illegal constant" business comes from the possibility of syntactically + * correct but valuely wrong sexagesimal constants, such as 1:222:1. + * We don't want to abort in sexa() because it may be used to digest a query + * response and producing a quiet undefined op there is correct. + */ +void +o_pushconst ( + memel *argp +) +{ + /* argument is pointer to an operand */ + struct operand *op; + + op = (struct operand *) argp; + if (opundef (op)) + cl_error (E_UERR, "illegal constant"); + pushop (op); +} + +/* Push an index value onto the control stack for later use + * when the parameter is accessed. + */ +void +o_pushindex ( + int *mode +) +{ + struct operand op; + + if (cldebug) + printf ("PUSHINDEX: mode=%d loopset=%d\n", *mode, imloopset); + + if (*mode == 0) { /* Normal array index reference. */ + opcast(OT_INT); + op = popop(); + push (op.o_val.v_i); + } else if (*mode == -1 || imloopset) { + /* Array reference in implicit loop. */ + push (oarr_curr[i_oarr]); + i_oarr++; + if (i_oarr >= n_oarr) + i_oarr = 0; + } else { + /* This is the first array reference in an implicit loop. + * It must initialize the loop parameters. The argument + * is an offset to the initialization info. + */ + int stk; + + stk = pc + *mode; + + n_oarr = stack[stk++]; + for (i_oarr=0; i_oarr= n_oarr) + i_oarr = 0; + } + + /* Increment counter of number of indexes pushed. + */ + n_indexes++; +} + +/* . + */ +void +o_pushparam ( + memel *argp +) +{ + char *pname = (char *) argp; + char *pk, *t, *p, *f; + struct param *pp; + + breakout (pname, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + validparamget (pp, *f); +} + + +/* . + */ +void +o_redir (void) +{ + struct operand o; + char *fname, *mode; + + opcast (OT_STRING); + o = popop(); + fname = (o.o_val.v_s); + + if (newtask->t_flags & T_FOREIGN && newtask->t_stdout == stdout) { + /* If foreign task let ZOSCMD open the spool file. + */ + newtask->ft_out = comdstr (fname); + + } else if (strcmp (fname, IPCOUT) == 0) { + /* Redirect the task stdout via IPC to a subprocess. */ + newtask->t_stdout = newtask->t_out; + newtask->t_flags |= T_IPCIO; + + } else { + mode = (newtask->t_flags & T_STDOUTB) ? "wb" : "w"; + + if ((newtask->t_stdout = fopen (fname, mode)) == NULL) + cl_error (E_UERR, e_wopen, fname); + + newtask->t_flags |= T_MYOUT; + } +} + + +/* . + */ +void +o_redirin (void) +{ + struct operand o; + char *fname, *mode; + + opcast (OT_STRING); + o = popop(); + fname = (o.o_val.v_s); + + if (newtask->t_flags & T_FOREIGN && newtask->t_stdin == stdin) { + /* If foreign task let ZOSCMD open the command file. + */ + newtask->ft_in = comdstr (fname); + } else { + mode = (newtask->t_flags & T_STDINB) ? "rb" : "r"; + + if ((newtask->t_stdin = fopen (fname, mode)) == NULL) + cl_error (E_UERR, e_ropen, fname); + + newtask->t_flags |= T_MYIN; + } +} + + +/* GSREDIR -- Graphics stream redirection. + * . + */ +void +o_gsredir ( + memel *argp +) +{ + register char *ip; + register FILE *fp; + char *streams = (char *)argp; + struct operand o; + char *fname; + int count; + + /* Get the filename. + */ + opcast (OT_STRING); + o = popop(); + fname = o.o_val.v_s; + + /* Scan the redir token to determine the file access mode, e.g., if + * ">G", create a new file, and if ">>G", append to a file. + */ + for (count=0, ip=streams; *ip; ip++) + if (*ip == '>') + count++; + + if ((fp = fopen (fname, count > 1 ? "ab" : "wb")) == NULL) + cl_error (E_UERR, e_wopen, fname); + + /* The first string operand on the stack is some combination of the + * characters GIP, listing the streams (stdgraph, stdimage, stdplot) + * to be redirected to the named file. The lexical analyzer guarantees + * that we will not be called unless the string consists of some + * combination of the characters >GIP, hence error checking for other + * char, no chars, etc., is not needed. + */ + for (ip=streams; *ip; ip++) + if (*ip == 'G') { + newtask->t_flags |= T_MYSTDGRAPH; + newtask->t_stdgraph = fp; + } else if (*ip == 'I') { + newtask->t_flags |= T_MYSTDIMAGE; + newtask->t_stdimage = fp; + } else if (*ip == 'P') { + newtask->t_flags |= T_MYSTDPLOT; + newtask->t_stdplot = fp; + } +} + +void +o_doaddpipe ( + memel *argp +) +{ + XINT getpipe_pc = *argp; + char *x1, *pk, *t, *x2; + char *ltname; + struct operand o; + struct ltask *ltp; + char *addpipe(); + + /* ADDPIPE is called immediately before REDIR and before EXEC so we + * do not have to worry about storing the pipefile name in the dict. + * Our argument is the PC of the GETPIPE instruction, the args field + * of which is the taskname of the second task in the pipe. If either + * the new task (first task in the pipe) or the second task is a + * FOREIGN task, the pipe must be created as a text file. + */ + ltname = (char *)&(coderef(getpipe_pc)->c_args); + if (*ltname == '$') + ltname++; + breakout (ltname, &x1, &pk, &t, &x2); + ltp = cmdsrch (pk, t); + + binpipe = ((ltp == NULL || !(ltp->lt_flags & LT_FOREIGN)) && + !(newtask->t_flags & T_FOREIGN)); + + if (binpipe) + newtask->t_flags |= T_STDOUTB; + + o.o_type = OT_STRING; + o.o_val.v_s = comdstr (addpipe()); + pushop (&o); +} + +void +o_dogetpipe ( + memel *argp /* name of ltask (not used) */ +) +{ + struct operand o; + char *getpipe(), *comdstr(); + + /* GETPIPE is called immediately before REDIRIN and before EXEC so we + * do not have to worry about storing the pipefile name in the dict. + * The flag binpipe is set by the last ADDPIPE if the pipe is a binary + * file. + */ + if (binpipe) + newtask->t_flags |= T_STDINB; + + o.o_type = OT_STRING; + o.o_val.v_s = comdstr (getpipe()); + pushop (&o); +} + + +void +o_rmpipes ( + memel *argp +) +{ + delpipes ((int)*argp); +} + + +void +o_doreturn (void) +{ + eprintf ("return not implemented\n"); +} + +/* ... . + * do the scan function. first op on stack is number of string ops to + * follow, rest are names of destination params. SCAN scans the standard + * input. + */ +void +o_doscan (void) +{ + struct operand o; + + o = popop(); + cl_scan (o.o_val.v_i - 1, "stdin"); +} + +void +o_doscanf (void) +{ + struct operand o; + struct operand o_sv[64]; + char format[SZ_LINE]; + int nargs, i; + + /* Get number of arguments. */ + o = popop(); + nargs = o.o_val.v_i; + + /* Get scan format. Unfortunately the way the parser works this + * is the last operand on the stack. We need to pop and save the + * first nargs-1 operands and restore them when done. + */ + for (i=0; i < nargs-1; i++) + o_sv[i] = popop(); + + o = popop(); + if ((o.o_type & OT_BASIC) != OT_STRING) + cl_error (E_UERR, "scanf: bad format string\n"); + strcpy (format, o.o_val.v_s); + + for (--i; i >= 0; i--) + pushop (&o_sv[i]); + + /* Do the scan. */ + cl_scanf (format, nargs-2, "stdin"); +} + +/* ... . + * Do the fscan function. First op on stack is number of string ops to + * follow. Next one is the name of the source parameter, rest are names of + * destination params. + */ +void +o_dofscan (void) +{ + struct operand o; + + o = popop(); + cl_scan (o.o_val.v_i - 1, ""); +} + +void +o_dofscanf (void) +{ + struct operand o; + struct operand o_sv[64]; + char format[SZ_LINE]; + char pname[SZ_FNAME]; + int nargs, i; + + /* Get number of arguments. */ + o = popop(); + nargs = o.o_val.v_i; + + /* Get scan format and input parameter name. The arguments on the + * stack are pushed in the order input param name, format string, + * and then the output arguments. + */ + + /* Get output arguments. */ + for (i=0; i < nargs-2; i++) + o_sv[i] = popop(); + + /* Get format string. */ + o = popop(); + if ((o.o_type & OT_BASIC) != OT_STRING) + cl_error (E_UERR, "fscanf: bad format string\n"); + strcpy (format, o.o_val.v_s); + + /* Get parameter name. */ + o = popop(); + if ((o.o_type & OT_BASIC) != OT_STRING) + cl_error (E_UERR, "fscanf: bad input parameter specification\n"); + strcpy (pname, o.o_val.v_s); + + /* Restore the output argument operands. */ + for (--i; i >= 0; i--) + pushop (&o_sv[i]); + + /* Restore the input parameter name operand. */ + o.o_type = OT_STRING; + o.o_val.v_s = pname; + pushop (&o); + + /* Do the scan. */ + cl_scanf (format, nargs-2, ""); +} + +/* . + */ +void +o_sub (void) +{ + binop (OP_SUB); +} + +/* . + */ +void +o_subassign ( + memel *argp +) +{ + /* operands are backwards on stack, so negate and add. can get by + * with this as long as subtraction is never defined for strings. + * if it is someday, will have to do something like in addassign. + */ + char *pname = (char *) argp; + char *pk, *t, *p, *f; + struct param *pp; + + breakout (pname, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + + unop (OP_MINUS); + validparamget (pp, *f); + binop (OP_ADD); + paramset (pp, *f); + pp->p_flags |= P_SET; +} + +/* Doswitch finds the appropriate location to jump to in the + * jump table and goes there. + */ +void +o_doswitch ( + int *jmpdelta +) +{ + int pdft, icase, jmptable; + int value; + struct operand o; + memel delta; + /* Remember to subtract 3 because PC has already been incremented. */ + jmptable = *jmpdelta + pc - 3; + + o = popop(); + if (o.o_type == OT_INT) + value = o.o_val.v_i; + else if (o.o_type == OT_STRING) { + if (*o.o_val.v_s != '\0' && *(o.o_val.v_s+1) == '\0') + value = (int) *o.o_val.v_s; + else + cl_error(E_UERR, "Illegal switch value."); + } else + cl_error (E_UERR, "Illegal switch value."); + + pdft = stack[jmptable]; + + if (cldebug) + eprintf ("doswitch: pdft=%d\n", pdft); + + /* Loop over cases. + */ + for (icase= jmptable + 1; stack[icase] != 0; icase++) { + int nval, ival, pcase; + memel *val; + + pcase = stack[icase] + pc - 3; + nval = coderef(pcase)->c_length - 2; + + /* Loop over all values for a particular case. + */ + val = & (coderef(pcase)->c_args); + for (ival=0; ivalt_pfp; + pp = ppfind (pfp, t, p, 0, NO); + if (pp == NULL) + cl_error (E_UERR, e_pnonexist, p); + if ((XINT)pp == ERR) + cl_error (E_UERR, e_pambig, p, newtask->t_ltp->lt_lname); + + o.o_type = OT_BOOL; + o.o_val.v_i = NO; + pushop (&o); + paramset (pp, FN_VALUE); + if (pp->p_type & PT_PSET) + psetreload (pfp, pp); + + pp->p_flags |= P_CLSET; +} + +void +o_swon ( + memel *argp +) +{ + register char *pname = (char *)argp; + register struct param *pp; + struct pfile *pfp; + struct operand o; + char *pk, *t, *p, *f; + + breakout (pname, &pk, &t, &p, &f); + if (*pk) + cl_error (E_UERR, e_simplep, p); + + pfp = newtask->t_pfp; + pp = ppfind (pfp, t, p, 0, NO); + if (pp == NULL) + cl_error (E_UERR, e_pnonexist, p); + if ((XINT)pp == ERR) + cl_error (E_UERR, e_pambig, p, newtask->t_ltp->lt_lname); + + o.o_type = OT_BOOL; + o.o_val.v_i = YES; + pushop (&o); + paramset (pp, FN_VALUE); + if (pp->p_type & PT_PSET) + psetreload (pfp, pp); + + pp->p_flags |= P_CLSET; +} + + +/* FIXLANGUAGE -- Called only once, during startup after processing the + * cl startup file (clpackage.cl) to set the PKCCL flag for task LANGUAGE + * in the package CLPACKAGE. Thereafter, when language is executed it + * will merely cause the current package to be changed. This cannot be + * done in the conventional way since clpackage.language() is never + * executed to load the language package, since it is the root package. + */ +void +o_fixlanguage (void) +{ + register struct ltask *ltp; + + ltp = ltasksrch (CLPACKAGE, ROOTPACKAGE); + ltp->lt_flags |= (LT_PACCL|LT_CL); + ltp->lt_pkp = pacfind (ROOTPACKAGE); +} + + +/* the opcode jump table. + * + * order of the entries here must agree with constants in opcodes.h. + * if the name is a keyword in C or a common library entry point, + * then precede it with "do" but alphabetize it according to its intended name. + */ + +void (*opcodetbl[])() = { +/* 0 */ o_undefined, + +/* 1 */ o_absargset, +/* 2 */ o_add, +/* 3 */ o_addassign, +/* 4 */ o_doaddpipe, +/* 5 */ o_allappend, + +/* 6 */ o_allredir, +/* 7 */ o_and, +/* 8 */ o_append, +/* 9 */ o_assign, +/* 10 */ o_biff, + +/* 11 */ o_call, +/* 12 */ 0, /* The CASE operand is never executed.*/ +/* 13 */ o_chsign, +/* 14 */ o_concat, +/* 15 */ 0, /* The DEFAULT operand is never executed. */ + +/* 16 */ o_div, +/* 17 */ o_divassign, +/* 18 */ o_doend, +/* 19 */ o_eq, +/* 20 */ o_exec, + +/* 21 */ o_dofscan, +/* 22 */ o_dofscanf, +/* 23 */ o_ge, +/* 24 */ o_dogoto, +/* 25 */ o_dogetpipe, + +/* 26 */ o_gt, +/* 27 */ o_immed, +/* 28 */ o_indirabsset, +/* 29 */ o_indirposset, +/* 30 */ o_indxincr, + +/* 31 */ o_inspect, +/* 32 */ o_intrinsic, +/* 33 */ o_le, +/* 34 */ o_lt, +/* 35 */ o_mul, + +/* 36 */ o_mulassign, +/* 37 */ o_ne, +/* 38 */ o_not, +/* 39 */ o_or, +/* 40 */ o_osesc, + +/* 41 */ o_posargset, +/* 42 */ o_dopow, +/* 43 */ o_doprint, +/* 44 */ o_pushconst, +/* 45 */ o_pushindex, + +/* 46 */ o_pushparam, +/* 47 */ o_redir, +/* 48 */ o_redirin, +/* 49 */ o_rmpipes, +/* 50 */ o_doreturn, + +/* 51 */ o_doscan, +/* 52 */ o_doscanf, +/* 53 */ o_sub, +/* 54 */ o_subassign, +/* 55 */ o_doswitch, + +/* 56 */ o_swoff, +/* 57 */ o_swon, +/* 58 */ o_fixlanguage, +/* 59 */ o_gsredir, +/* 60 */ o_catassign +}; diff --git a/pkg/cl/opcodes.h b/pkg/cl/opcodes.h new file mode 100644 index 00000000..bcce4b7f --- /dev/null +++ b/pkg/cl/opcodes.h @@ -0,0 +1,95 @@ +/* + * OPCODES.H -- This structure is a template for each instruction in the + * dictionary. C_opcode is a constant, from below, and is an index into + * opcodetbl[]; c_length is the total length, including the opcode, in # of + * integers; the address of c_args will be the address of the first argument + * (or if there is just one, it IS the first argument). + * + * The intent is to allow invoking the opcode with + * (*opcodetbl[cp->c_opcode]) (&cp->c_args) + * where cp is a ptr to struct codeentry. + */ + +struct codeentry { + memel c_opcode; /* opcodetbl index; see below */ + memel c_length; /* total length in memory elements */ + memel c_args; /* addr of this is addr of first arg */ +}; + +extern void (*opcodetbl[])(); + +/* manifest constant opcodes used in c_opcode. + * value is index into opcodetbl[]. + */ + +#define ABSARGSET 1 +#define ADD 2 +#define ADDASSIGN 3 +#define ADDPIPE 4 +#define ALLAPPEND 5 + +#define ALLREDIR 6 +#define AND 7 +#define APPENDOUT 8 +#define ASSIGN 9 +#define BIFF 10 + +#define CALL 11 +#define CASE 12 +#define CHSIGN 13 +#define CONCAT 14 +#define DEFAULT 15 + +#define DIV 16 +#define DIVASSIGN 17 +#define END 18 +#define EQ 19 +#define EXEC 20 + +#define FSCAN 21 +#define FSCANF 22 +#define GE 23 +#define GOTO 24 +#define GETPIPE 25 + +#define GT 26 +#define IMMED 27 +#define INDIRABSSET 28 +#define INDIRPOSSET 29 +#define INDXINCR 30 + +#define INSPECT 31 +#define INTRINSIC 32 +#define LE 33 +#define LT 34 +#define MUL 35 + +#define MULASSIGN 36 +#define NE 37 +#define NOT 38 +#define OR 39 +#define OSESC 40 + +#define POSARGSET 41 +#define POW 42 +#define PRINT 43 +#define PUSHCONST 44 +#define PUSHINDEX 45 + +#define PUSHPARAM 46 +#define REDIR 47 +#define REDIRIN 48 +#define RMPIPES 49 +#define RETURN 50 + +#define SCAN 51 +#define SCANF 52 +#define SUB 53 +#define SUBASSIGN 54 +#define SWITCH 55 + +#define SWOFF 56 +#define SWON 57 +#define FIXLANGUAGE 58 +#define GSREDIR 59 +#define CATASSIGN 60 diff --git a/pkg/cl/operand.c b/pkg/cl/operand.c new file mode 100644 index 00000000..65dbab0c --- /dev/null +++ b/pkg/cl/operand.c @@ -0,0 +1,429 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "config.h" +#include "errs.h" +#include "operand.h" +#include "param.h" +#include "grammar.h" +#include "mem.h" +#include "task.h" /* to get currentask for prop */ +#include "construct.h" +#include "eparam.h" +#include "proto.h" + + +/* + * OPERAND -- Primitives for operations upon operands, as used on the + * operand stack (runtime arithmetic). + */ + +extern int cldebug; +extern char *truestr; +extern char *falsestr; +extern char *nullstr; +extern char *indefstr; +extern char *indeflc; +extern char *eofstr; +extern char *epsilonstr; + + +/* SPROP -- Format the value of a parameter into the output string. + */ +void +sprop ( + register char *outstr, + register struct operand *op +) +{ + register int type; + char *index(); + + if (opundef (op)) + cl_error (E_IERR, "can not print an undefined operand"); + if (opindef (op)) { + strcpy (outstr, indefstr); + return; + } + + type = op->o_type & OT_BASIC; + switch (type) { + case OT_BOOL: + sprintf (outstr, op->o_val.v_i == NO ? falsestr : truestr); + break; + case OT_INT: + sprintf (outstr, "%d", op->o_val.v_i); + break; + case OT_REAL: + /* unix's %g suppresses '.' if no fractional part */ + sprintf (outstr, "%g", op->o_val.v_r); + if (index (outstr, '.') == NULL) + strcat (outstr, "."); + break; + case OT_STRING: + strcpy (outstr, op->o_val.v_s); + break; + default: + /* cannot happen because there are only 2 bits for 4 types. + cl_error (E_IERR, e_badsw, type, "fprop()"); + */ + ; + } +} + + +/* SPPARVAL -- Print value field of a parameter into a string. + */ +void +spparval ( + char *outstr, + struct param *pp +) +{ + struct operand o; + + if (!(pp->p_valo.o_type & OT_UNDEF)) { + paramget (pp, FN_VALUE); + o = popop(); + sprop (outstr, &o); + } else + outstr[0] = '\0'; +} + + +/* Print an operand on stream fp. + * o_val is printed with proper format; no trailing nl. + * handle indefinite and abort on undefined. + */ +void +fprop ( + FILE *fp, + struct operand *op +) +{ + /* Use MAXPROMPT to give greatest length we expect to print. + */ + char outstr[MAXPROMPT+1], *out; + char newstr[SZ_LINE], *new; + + sprop (outstr, op); + + /* Convert embedded newlines to \n. + */ + new = newstr; + out = outstr; + for (; *out != '\0' && ((new-newstr) < SZ_LINE-1 ); out++, new++) { + if (*out == '\n') { + *new++ = '\\'; + *new = 'n'; + } else { + *new = *out; + } + } + *new = '\0'; + + fputs (newstr, fp); + if (ferror (fp)) + cl_error (E_IERR, "write error within fprop()"); +} + + +/* print operand, using fprop, to our t_stdout. + */ +void +oprop ( + struct operand *op +) +{ + fprop (currentask->t_stdout, op); +} + + +/* print operand, using fprintf, to currentask. + */ +void +prop ( + struct operand *op +) +{ + fprop (currentask->t_out, op); +} + + +/* pop the top element, which must be of type string, and use it as the + * name of a parameter which is then found and pushed. + * call error() if popped op is not a string; DO NOT CAST into string. + */ +void +opindir (void) +{ + struct operand nameop; + struct param *indirpp; + char *pk, *t, *p, *f; + + nameop = popop(); + if ((nameop.o_type & OT_BASIC) != OT_STRING) + cl_error (E_IERR, "non-string operand seen by opindir()"); + breakout (nameop.o_val.v_s, &pk, &t, &p, &f); + indirpp = paramsrch (pk, t, p); + validparamget (indirpp, *f); +} + + +/* Pop top operand and replace it with one cast to type newtype. + * Newtype is assumed to not have OT_INDEF or OT_UNDEF set. + * Call error() if trying to convert strings to something else unless + * it is a length 1 string conversion to integer which we take to be + * conversion from char to int. + * + * Do nothing if already the correct type, regardless of whether it is indef + * or undef. + * N.B. we use intimate knowledge of the stack layout to do the simple cases. + */ +void +opcast (int newtype) +{ + struct operand o, result; + struct operand *op; + + /* Do nothing if already the correct type, + * regardless of whether it is indef or undef. + */ + op = (struct operand *) &stack[stack[topos]+1]; + if ((op->o_type & OT_BASIC) == newtype) + return; + + o = popop(); + result.o_type = newtype; + + if (opindef (&o)) { + /* manufacture another indefinite but with the new type */ + setopindef (&result); + goto pushresult; + } + + switch (newtype) { + default: + /* Coerce all unknowns to type integer. Actually this cannot + * happen since the 4 types are encoded in 2 bits. + */ + newtype = OT_INT; + /* continue... */ + + case OT_BOOL: + /* Coercion of booleans is not permitted */ + if (o.o_type != OT_BOOL) +{ ready_(); + cl_error (E_UERR, + "Non-boolean operand used where boolean expected"); +} + break; + + case OT_INT: + switch (o.o_type) { + case OT_BOOL: + cl_error (E_UERR, "Attempt to coerce a boolean to an integer"); + case OT_INT: + result.o_val.v_i = o.o_val.v_i; + break; + case OT_REAL: + result.o_val.v_i = o.o_val.v_r; + break; + case OT_STRING: + if (*o.o_val.v_s != '\0' && *(o.o_val.v_s+1) == '\0') + result.o_val.v_i = (int) *o.o_val.v_s; + else + cl_error (E_UERR, e_nostrcnv); + break; + default: + goto err; + } + break; + + case OT_REAL: + switch (o.o_type) { + case OT_BOOL: + cl_error (E_UERR, "Attempt to coerce a boolean to a real"); + case OT_INT: + result.o_val.v_r = o.o_val.v_i; + break; + case OT_REAL: + result.o_val.v_r = o.o_val.v_r; + break; + case OT_STRING: + cl_error (E_UERR, e_nostrcnv); + default: + goto err; + } + break; + + case OT_STRING: { + char numstr[SZ_LINE]; + switch (o.o_type) { + case OT_BOOL: + result.o_val.v_s = + o.o_val.v_i == NO ? falsestr : truestr; + break; + case OT_INT: + sprintf (numstr, "%d", o.o_val.v_i); + result.o_val.v_s = numstr; + break; + case OT_REAL: + sprintf (numstr, "%g", o.o_val.v_r); + result.o_val.v_s = numstr; + break; + case OT_STRING: + strcpy (numstr, o.o_val.v_s); + result.o_val.v_s = numstr; + break; + default: goto err; + } + + /* Must do pushop here to use numstr */ + pushop (&result); + return; + + } /* end case OT_STRING */ + } + +pushresult: + pushop (&result); + return; + +err: + cl_error (E_IERR, e_badsw, o.o_type, "opcast()"); +} + + +/* MAKEOP -- Read through string s and create and return an operand of given + * type. Type must be strictly OT_BASIC. See the various cases for + * considerations unique to each. Set OT_UNDEF if string does not look like + * it is the correct type or it is null length; set OT_INDEF if s is the + * indefstr.. Null length strings of type OT_STRING are not considered + * undefined, however. + */ +struct operand +makeop ( + char *str, + int type +) +{ + register char *s, *ip; + register char c; + char *index(), *format; + char hexnum[MAX_DIGITS]; + char firstchar; + struct operand o; + + maybeindex = 0; + s = str; + if (type & ~OT_BASIC) + cl_error (E_IERR, e_badsw, type, "makeop()"); + + /* Leading whitespace is ignored except in strings. */ + o.o_type = type; + if (type != OT_STRING) + while (*s == ' ' || *s == '\t') + s++; + + if ((type != OT_STRING && + !strcmp (indefstr, s)) || !strcmp (indeflc, s)) { + setopindef (&o); + return (o); + } + if (*s == '\0' && type != OT_STRING) { + setopundef (&o); + return (o); + } + + switch (type) { + case OT_BOOL: + /* s is converted, IN PLACE, to lower case */ + makelower (s); + /* Accept either "y" or "yes", "n" or "no" */ + if (((s[0] == truestr[0]) && (s[1] == '\0')) || + (strcmp (s, truestr) == 0)) + o.o_val.v_i = YES; + else if (((s[0] == falsestr[0]) && (s[1] == '\0')) || + (strcmp (s, falsestr) == 0)) + o.o_val.v_i = NO; + else + setopundef (&o); + break; + + case OT_INT: + /* trailing 'b' or 'B' means convert as octal. + * trailing 'x' or 'X' means convert as hex. + * Set format to appropriate scanf format. Note we must test + * for hex number first, since 'b' is legal in hex numbers. + */ + firstchar = *s; + if (*s != '\'' && *s != '"') + makelower (s); + + if (index (s, 'x') != NULL) { + strcpy (hexnum, "0x"); + strcat (hexnum, s); + format = "%x"; + } else if (index (s, 'b') != NULL) { + format = "%o"; + } else + format = "%d"; + + if (sscanf (s, format, &o.o_val.v_i) != 1) { + /* Check if string has exactly one character. + * Use firstchar because it hasn't been forced to lower case. + */ + if (*s && !(*(s+1)) ) + o.o_val.v_i = firstchar; + /* Quoted character? */ + else if ( (*s == '\'' || *s == '"') && (*s == *(s+2) ) && + !(*(s+3)) ) + o.o_val.v_i = *(s+2); + else + setopundef (&o); + } + + break; + + case OT_REAL: { + /* If there is only a single colon this might be + * an array index range. If so set flag. + * Check for decimal point after first colon also. + */ + char *colon; + + if ( (colon=index (s, ':') ) != NULL) { + if (index (colon+1, ':') == NULL && + index (colon+1, '.') == NULL) + maybeindex++; + + o = sexa (s); + } else if (sscanf (s, "%lf", &o.o_val.v_r) != 1) + setopundef (&o); + break; + } + case OT_STRING: + /* set v_s to s and strip off any surrounding quotes. + * trailing " or ' will be reset, IN-PLACE, to '\0'. + */ + ip = s; + c = *ip++; + if (c == '\'' || c == '"') { + while (*ip) + ip++; + if (*--ip == c) { + s++; /* skip leading quote */ + *ip = '\0'; /* remove trailing quote */ + } + } + o.o_val.v_s = s; + } + + return (o); +} diff --git a/pkg/cl/operand.h b/pkg/cl/operand.h new file mode 100644 index 00000000..ac10fc05 --- /dev/null +++ b/pkg/cl/operand.h @@ -0,0 +1,167 @@ +/* + * OPERAND.H -- Definition of an operand, defined operation codes and function + * type declarations. + */ + +/* ---------- + * union of all possible fundamentally allowed data types in an operand + */ +union value { + int v_i; /* integer, also doubles as boolean */ + double v_r; /* floating real; all assumed double precision*/ + char *v_s; /* char string */ + struct arr_desc *v_a; /* Array of int, double or string. */ +}; + +struct operand { + short o_type; /* need 16 bits; see type codes below */ + union value o_val; +}; + +union arrhead { + int *a_i; /* Pointer to ints (or bools). */ + double *a_r; /* Pointer to reals. */ + char **a_s; /* Pointer to strings. */ +}; + +struct arr_desc { + union arrhead a_ptr; /* Pointer to elements in array.*/ + int a_dim; /* Dimensionality of array. */ + short a_len; /* Length of first dimension. */ + short a_off; /* Offset of first dimension. */ +}; +/* Note that in an multi-dimensional array a_len and a_off will + * be repeated for each dimension. + */ + + +/* this should be the size of operand IN INTS so that the instruction + * pointer instptr and operand stack index topos can be properly manipulated. + */ +#define OPSIZ btoi (sizeof (struct operand)) + + +/* ---------- + * return value of operand *o. + * not useful for strings as cannot include v_s in this. + * note that both OT_INT and OT_BOOL use v_i. + * we assume that o_type only includes OT_BASIC bits. + */ +#define VALU(o) (((o)->o_type == OT_REAL) ? (o)->o_val.v_r : (o)->o_val.v_i) + + +/* ---------- + * o_type flag defn's; also used in p_type, see param.h. + * the value of o_type&OT_BASIC is the basic type of the operand. there is + * no such thing as an undefined type, only an undefined value. + * an operand's o_value is unused if OT_INDEF or UNDEF is set. + */ +#define OT_BOOL 0 /* actually stored as an int, 0 or 1 */ +#define OT_INT 1 /* ints store least 16 bits */ +#define OT_REAL 2 /* no float/double distinction */ +#define OT_STRING 3 /* any kind of in-core char storage */ +#define OT_BASIC 03 /* mask to get only the type bits */ + +#define OT_INDEF 004 /* value is undefined (not an err) */ +#define OT_UNDEF 010 /* value is just not known (an err) */ + + +/* test and set functions for indefinite and undefined operands. + * note that the basic type is not disturbed during setting. + */ +#define opindef(op) (((op)->o_type & OT_INDEF) != 0) +#define opundef(op) (((op)->o_type & OT_UNDEF) != 0) +#define setopindef(op) ((op)->o_type |= OT_INDEF) +#define setopundef(op) ((op)->o_type |= OT_UNDEF) + + +/* ---------- + * binary operations, handled by binop(). + * if these are each in numeric order, the switches in binop(), unop(), etc + * will be compiled as jump tables. + */ +#define OP_ADD 1 +#define OP_SUB 2 +#define OP_MUL 3 +#define OP_DIV 4 +#define OP_POW 5 /* power, as in a**x */ +#define OP_MAX 6 +#define OP_MIN 7 +#define OP_MOD 8 +#define OP_ATAN2 9 /* arctangent with two args */ +#define OP_CONCAT 10 /* string concatenatation */ +#define OP_RADIX 11 /* string = radix (decimal, newradix) */ +#define OP_STRIDX 12 /* first occurrence of a char in str */ +#define OP_STRLDX 13 /* last occurrence of a char in str */ +#define OP_STRSTR 14 /* first occurrence of str1 in str2 */ +#define OP_STRLSTR 15 /* last occurrence of str1 in str2 */ + +/* binary logical expressions, handled by binexp(); + * uses o_val.v_i as boolean result + */ +#define OP_LT 1 +#define OP_GT 2 +#define OP_LE 3 +#define OP_GE 4 +#define OP_EQ 5 +#define OP_NE 6 +#define OP_OR 7 +#define OP_AND 8 + +/* unary expressions, handled by unexp(); interprets o_val as boolean */ +#define OP_TRUE 1 /* sets o_val to 1 */ +#define OP_FALSE 2 /* " " 0 */ +#define OP_NOT 3 /* sets non-0 o_val to 0, 0 to 1 */ + +/* unary operations, handled by unop() */ +#define OP_ABS 1 /* absolute value */ +#define OP_ACCESS 2 /* does named file exist */ +#define OP_COS 3 /* cosine */ +#define OP_DEFTASK 4 /* is named task defined */ +#define OP_DEFPAR 5 /* is named parameter defined */ +#define OP_DEFPAC 6 /* is named package loaded */ +#define OP_DEFVAR 7 /* does environment variable exist */ +#define OP_ENVGET 8 /* get environment variable defn */ +#define OP_EXP 9 /* natural antilog, as in e ** x */ +#define OP_FRAC 10 /* fractional part of a real number */ +#define OP_IMACCESS 11 /* does named image exist */ +#define OP_INT 12 /* coerce to int */ +#define OP_LOG 13 /* natural logarithm */ +#define OP_LOG10 14 /* decimal logarithm */ +#define OP_NSCAN 15 /* number of items conv. in last SCAN */ +#define OP_MINUS 16 /* unary negation */ +#define OP_MKTEMP 17 /* make unique file name */ +#define OP_NINT 18 /* return nearest integer (round) */ +#define OP_OSFN 19 /* convert vfn to OS filename */ +#define OP_REAL 20 /* coerce to real */ +#define OP_SIN 21 /* sine */ +#define OP_SQRT 22 /* square root */ +#define OP_STR 23 /* coercion to type string */ +#define OP_SUBSTR 24 /* extract substring */ +#define OP_TAN 25 /* tangent */ +#define OP_STRLEN 26 /* length of a string constant */ +#define OP_ISINDEF 27 /* is value INDEF */ +#define OP_STRLWR 28 /* convert string to lower case */ +#define OP_STRUPR 29 /* convert string to upper case */ + +/* These area used by intrinsic() to categorize the various opcodes. + * The lower OP_BITS encode the specific function, while bits above that + * encode the category. Thus, none of the OP_XXX codes above may use more + * than OP_BITS, ie, be larger than OP_MASK. + */ +#define OP_BITS 8 +#define OP_MASK 255 /* could be 2**OP_BITS-1 if C had ** */ +#define UNOP (1< + +#include "config.h" +#include "operand.h" +#include "param.h" +#include "grammar.h" +#include "mem.h" +#include "task.h" +#include "errs.h" +#include "clmodes.h" +#include "construct.h" +#include "proto.h" + + +/* + * PARAM -- Operations upon parameters. + */ + +extern int cldebug; +extern char *undefval; +extern char *nullstr; +extern char *eofstr; +extern char *indefstr; +extern char *indeflc; + +XINT parhead; /* dict index of first pfile */ + + +#define INDEX_OFFSET 0 /* Offsets using index list. */ +#define DIRECT_OFFSET 1 /* Offsets put on stack directly. */ +int mode_offset = INDEX_OFFSET; + +char *loc_field = "Attempt to access undefined field in local variable %s.\n"; + +/* PARAMFIND -- Search for a parameter with the given name off pfile *pfp. + * If name is null, then search for one in n'th pos, counting from 0. + * not counting M_HIDDEN params. + * Return NULL if cannot find one with given name or at given position + * or ERR if allowing abbreviations and pname is ambiguous. + * Never return ERR if looking for a positional arg; some callers of paramfind() + * Depend on this and don't check for ERR; beware if change it. + */ +struct param * +paramfind ( + struct pfile *pfp, + char *pname, + int pos, + int exact +) +{ + register char first_char; + register struct param *pp; + struct ltask *ltp; + + if (pfp == NULL) + return (NULL); + + if (cldebug) { + eprintf ("paramfind() looking down pfile `%s'/%x for ", + (ltp = pfp->pf_ltp) ? ltp->lt_lname : "", pfp); + if (pname != NULL && *pname != '\0') + eprintf ("`%s'\n", pname); + else + eprintf ("position %d\n", pos); + } + + /* Check for both ways "name may be null" */ + if (pname == NULL || *pname == '\0') { + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) + if (!(pp->p_mode & M_HIDDEN) && pos-- == 0) + return (pp); + + } else if (abbrev() && !exact) { + /* Settle for abbreviation of name */ + struct param *candidate; + int n; + + candidate = NULL; + n = strlen (pname); + first_char = pname[0]; + + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + if (*pp->p_name == first_char) + if (!strncmp (pp->p_name, pname, n)) { + if (pp->p_name[n] == '\0') + return (pp); /* exact hit */ + if (candidate == NULL) + candidate = pp; + else + candidate = (struct param *) ERR; + } + } + + return (candidate); + + } else { + /* Name must be exact. */ + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + if (!strcmp (pp->p_name, pname)) + return (pp); + } + } + + return (NULL); +} + + +/* PARAMSET -- Pop top operand and assign to given field of param *pp, + * with possible type conversion via opcast() to pp->p_type. + * Be darn sure to pop an operand in all cases! + * All preallocated string storage ends with null; take care to preserve this + * by never copying into full length. assigning into the name of a + * list-structured param closes the file if it's open and clears EOF. + * We don't check if the popped op is undefined. + * + * Parameter indirection complicates setting the p_value, p_min, and p_max + * fields (the only fields for which indirection is permitted). When one + * of these fields is indirect it is a string valued operand containing + * as value a string of the form ")indirparam". Hence, the value, min, or + * max field may be of type string while the parameter itself (p_type) is + * of some other datatype. Indirection will be overriden if the operand + * to be set is a data value rather than an indirect reference string. + * If the operand is a data value the parameter field may change its datatype. + * If the operand is an indirect reference the field must already be of type + * string with sufficient string storage allocated for the new string. + * String storage must be allocated when the pfile is loaded. + * + * Enumerated types are implemented as a string of | separated fields + * stored in the p_min field. The p_min field must have been set to some + * string value when the pfile was loaded or storage will not have been + * allocated. While the enumerated type is supported only for string valued + * params, integers may be stored as strings in a string valued parameter + * to permit enumerating the legal values of an integer parameter, e.g.: + * + * order of interpolator (3|5|7) (5): + */ +void +paramset ( + register struct param *pp, + char field +) +{ + struct operand o; + int bastype; /* OT_BASIC portion of p_type */ + int valtype; /* OT_BASIC type of current value */ + int optype; /* OT_BASIC type of operand */ + int arrflag; /* Array indicator. */ + int list; /* set if p->p_type & PT_LIST */ + int len; /* max length of storage, if in-line */ + + o = popop(); + + list = pp->p_type & PT_LIST; + arrflag = pp->p_type & PT_ARRAY; + bastype = pp->p_type & OT_BASIC; + valtype = pp->p_valo.o_type & OT_BASIC; + optype = o.o_type & OT_BASIC; + + /* Check if unauthorized access to local variable. + */ + if (pp->p_mode&M_LOCAL && field != FN_VALUE && field != FN_NULL) + cl_error (E_UERR, loc_field, pp->p_name); + + /* If a CL parameter, value may need parsing to set some internal + * variables (logging, eparam, etc.). Take care of this before + * changing the value of the parameter, in case the new value is + * illegal. + */ + if (pp->p_flags & P_CL) + parse_clmodes (pp, &o); + + switch (field) { + case FN_NAME: + cl_error (E_UERR, + "may not change name of parameter `%s'", pp->p_name); + case FN_TYPE: + cl_error (E_UERR, + "may not change type of parameter `%s'", pp->p_name); + + case FN_MODE: + if (optype != OT_STRING) + cl_error (E_UERR, "modes are strings"); + if (opindef (&o)) + cl_error (E_UERR, "tried to set mode of `%s' to %s", + pp->p_name, indefstr); + o.o_type = pp->p_mode; /* reuse briefly as a temp */ + if ((pp->p_mode = scanmode (o.o_val.v_s)) == ERR) { + pp->p_mode = o.o_type; /* restore from temp */ + cl_error (E_UERR, "bad mode string `%s'", o.o_val.v_s); + } + break; + + case FN_NULL: + case FN_VALUE: + /* Assigning into a list param closes an existing file, + * changes the name of the list file, and clears P_LEOF. + */ + if (list) { + closelist (pp); + pp->p_flags &= ~P_LEOF; + } + + /* If parameter indirection is in effect the datatype of the value + * field will be string, while the parameter type itself may be + * any datatype. If we are overriding redirection with a real + * value for the parameter then the datatype of p_valo may change. + */ + if (!list && bastype != OT_STRING && + (valtype != OT_STRING || optype != OT_STRING)) { + /* Set nonstring datatype. + */ + if (optype != bastype) { + pushop (&o); + opcast (bastype); + o = popop(); + } + + if (!arrflag) + pp->p_valo = o; + else { + /* We must generate reference to appropriate value. */ + int offset; + int *p_i; + double *p_r; + + offset = getoffset (pp); + + if (bastype == OT_BOOL || bastype == OT_INT) { + p_i = pp->p_aval.a_i + offset; + *p_i = o.o_val.v_i; + } else if (bastype == OT_REAL) { + p_r = pp->p_aval.a_r + offset; + *p_r = o.o_val.v_r; + } + } + break; /* break from switch */ + } + + len = pp->p_lenval; + if (optype != OT_STRING) { + pushop (&o); + opcast (bastype); + o = popop(); + } + + if (bastype == OT_STRING && arrflag) { + char **p_s; + int offset; + + offset = getoffset (pp); + p_s = pp->p_aval.a_s + offset; + strncpy (*p_s, o.o_val.v_s, len-1); + break /* out of switch */; + } + + pp->p_valo.o_type = o.o_type; + if (!opindef (&o)) + strncpy (pp->p_val.v_s, o.o_val.v_s, len-1); + break; + + case FN_MIN: /* minimum */ + if (bastype == OT_BOOL || + pp->p_type & (PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY|PT_PSET)) + cl_error (E_UERR, e_nominmax); + + /* If string type and no values were enumerated in the pfile, + * no storage will have been allocated in the min field for the + * enumeration list and we must abort. Otherwise space is avail + * for PF_SZMINSTR chars. + */ + if (bastype == OT_STRING && pp->p_flags & P_UMIN) + cl_error (E_UERR, "string storage not allocated for p_min"); + + if (bastype == OT_STRING || + (valtype == OT_STRING && optype == OT_STRING)) { + if (optype != OT_STRING) { + pushop (&o); + opcast (OT_STRING); + o = popop(); + } + + if (opindef (&o)) + pp->p_flags |= P_IMIN; + else { + strncpy (pp->p_min.v_s, o.o_val.v_s, PF_SZMINSTR-1); + pp->p_flags &= ~(P_IMIN|P_UMIN); + pp->p_mino.o_type = o.o_type; + } + + } else { + if (optype != bastype) { + pushop (&o); + opcast (bastype); + o = popop(); + } + pp->p_mino = o; + if (opindef (&o)) + pp->p_flags |= P_IMIN; + else { + pp->p_min = o.o_val; + pp->p_flags &= ~(P_IMIN|P_UMIN); + } + } + break; + + case FN_MAX: /* maximum */ + if (bastype == OT_BOOL || + (bastype == OT_STRING && !(pp->p_type & PT_FILNAM))) { + cl_error (E_UERR, e_nominmax); + } + + if (pp->p_type & PT_FILNAM) { + pushop (&o); + opcast (OT_STRING); + o = popop(); + if (opindef (&o)) + pp->p_flags |= P_IMAX; + else { + strncpy (pp->p_max.v_s, o.o_val.v_s, PF_SZMAXSTR-1); + pp->p_flags &= ~(P_IMAX|P_UMAX); + pp->p_maxo.o_type = o.o_type; + } + + } else { + pushop (&o); + opcast (bastype); + o = popop(); + pp->p_maxo = o; + if (opindef (&o)) + pp->p_flags |= P_IMAX; + else { + pp->p_max = o.o_val; + pp->p_flags &= ~(P_IMAX|P_UMAX); + } + } + break; + + case FN_PROMPT: /* the prompt string; length <= before */ + pushop (&o); + opcast (OT_STRING); + o = popop(); + if (opindef (&o)) + *pp->p_prompt = '\0'; + else { + len = strlen (pp->p_prompt); + strncpy (pp->p_prompt, o.o_val.v_s, len - 1); + } + break; + + default: + cl_error (E_IERR, e_badsw, field, "paramset()"); + } +} + + +/* VALIDPARAMGET -- Push given field of param onto stack. Read next entry + * in file if list-structured. If getting FN_NULL, query if in query mode + * or if pp is out of range. Call error if return value would be undefined. + */ +void +validparamget ( + register struct param *pp, + char field +) +{ + struct operand o; + + paramget (pp, field); + o = popop(); + if (opundef(&o)) + cl_error (E_UERR, + "The requested field of parameter `%s' is undefined", pp->p_name); + if (field == FN_NULL && pp->p_flags & P_LEOF) + cl_error (E_UERR, "EOF from list param `%s' in expression", + pp->p_name); + pushop (&o); +} + + +/* PARAMGET -- Push given field of param onto stack. Read next entry in file + * if list-structured. If getting FN_NULL, query if in query mode or if pp + * is out of range. Value returned may be undefined. + */ +void +paramget ( + register struct param *pp, + char field +) +{ + char mode[5]; /* used to turn bits into string */ + struct operand result; + char buf[20]; /* to stuff the expanded type in */ + char *bp; + int bastype; + int arrflag; + + bastype = pp->p_type & OT_BASIC; + arrflag = pp->p_type & PT_ARRAY; + + /* Check if unauthorized access to local variable. + */ + if (pp->p_mode&M_LOCAL && field != FN_VALUE && field != FN_NULL) + cl_error (E_UERR, loc_field, pp->p_name); + + switch (field) { + case FN_NAME: + result.o_type = OT_STRING; + result.o_val.v_s = pp->p_name; + break; + + case FN_TYPE: + result.o_type = OT_STRING; + switch (pp->p_type & OT_BASIC) { + case OT_STRING: + result.o_val.v_s = "s"; + break; + case OT_INT: + result.o_val.v_s = "i"; + break; + case OT_REAL: + result.o_val.v_s = "r"; + break; + case OT_BOOL: + result.o_val.v_s = "b"; + break; + default: + result.o_val.v_s = "?"; + break; + } + break; + + case FN_XTYPE: + result.o_type = OT_STRING; + + bp = buf; + if (pp->p_type & PT_LIST) + *bp++ = '*'; + else if (arrflag) + *bp++ = 'a'; + + switch (bastype) { + case OT_BOOL: + *bp++ = 'b'; + break; + case OT_INT: + *bp++ = 'i'; + break; + case OT_REAL: + *bp++ = 'r'; + break; + case OT_STRING: + *bp++ = 's'; + break; + } + + /* Overwrite the string descriptor that appears with PT_FILNAM, + * PT_STRUCT and the cursors. + */ + if (pp->p_type & PT_FILNAM) { + *--bp = 'f'; + if (pp->p_type & PT_FBIN) + *++bp = 'b'; + if (pp->p_type & PT_FNOE) + *++bp = 'n'; + if (pp->p_type & PT_FER) + *++bp = 'r'; + if (pp->p_type & PT_FTXT) + *++bp = 't'; + if (pp->p_type & PT_FEW) + *++bp = 'w'; + *++bp = '\0'; + + } else if (pp->p_type & PT_STRUCT) { + strcpy (--bp, "struct"); + } else if (pp->p_type & PT_GCUR) { + strcpy (--bp, "gcur"); + } else if (pp->p_type & PT_IMCUR) { + strcpy (--bp, "imcur"); + } else if (pp->p_type & PT_UKEY) { + strcpy (--bp, "ukey"); + } else if (pp->p_type & PT_PSET) { + strcpy (--bp, "pset"); + } else + *bp = '\0'; + + *bp = '\0'; + + result.o_val.v_s = buf; + break; + + + case FN_MODE: + makemode (pp, mode); + result.o_type = OT_STRING; + result.o_val.v_s = mode; + break; + + case FN_NULL: + /* Without an explicit field we give the meaningful "worth" + * of the param, which is not necessarilly the 4th param field. + * If PT_LIST, read entry from list. + */ + if (effmode (pp) & M_QUERY) { + /* Just query to get result. */ + query (pp); + result = popop(); + } else { + /* Use pp to get result; query if not in range. + */ + if (pp->p_type & PT_LIST) { + result = readlist (pp); /* may set P_LEOF */ + } else if (arrflag) { + /* If an array get appropriate value. + */ + int offset; + + offset = getoffset(pp); + result.o_type = bastype; + if (bastype == OT_BOOL || bastype == OT_INT) + result.o_val.v_i = *(pp->p_aval.a_i + offset); + else if (bastype == OT_REAL) + result.o_val.v_r = *(pp->p_aval.a_r + offset); + else if (bastype == OT_STRING) + result.o_val.v_s = *(pp->p_aval.a_s + offset); + } else + result = pp->p_valo; + + /* Do not range check if we have an indirect reference. + */ + if (!((result.o_type & OT_BASIC) == OT_STRING && + *result.o_val.v_s == PF_INDIRECT)) + if (!(pp->p_flags & P_LEOF) && !inrange (pp, &result)) { + query (pp); + result = popop(); + } + } + break; + + case FN_VALUE: + /* Explicit reference to the "value" field means return the + * value, or if indirect, the file name for the indirection. + */ + if (arrflag) { + int offset; + + offset = getoffset(pp); + result.o_type = bastype; + if (bastype == OT_BOOL || bastype == OT_INT) + result.o_val.v_i = *(pp->p_aval.a_i + offset); + else if (bastype == OT_REAL) + result.o_val.v_r = *(pp->p_aval.a_r + offset); + else if (bastype == OT_STRING) + result.o_val.v_s = *(pp->p_aval.a_s + offset); + } else + result = pp->p_valo; + break; + + case FN_LENGTH: + result.o_type = OT_INT; + result.o_val.v_i = pp->p_lenval; + break; + + case FN_MIN: + if (pp->p_flags & P_UMIN) + setopundef (&result); + else if (pp->p_flags & P_IMIN) + setopindef (&result); + else + result = pp->p_mino; + break; + + case FN_MAX: + if (pp->p_flags & P_UMAX) + setopundef (&result); + else if (pp->p_flags & P_IMAX) + setopindef (&result); + else + result = pp->p_maxo; + break; + + case FN_PROMPT: + result.o_type = OT_STRING; + result.o_val.v_s = pp->p_prompt; + break; + + default: + cl_error (E_IERR, e_badsw, field, "paramget()"); + } + + /* Parameter indirection. If the value of the parameter is given as + * ")paramspec" use the value of the referenced parameter. Multiple + * levels of indirection are permitted. + */ + if ((result.o_type & OT_BASIC) == OT_STRING && + *result.o_val.v_s == PF_INDIRECT) { + char redir[SZ_FNAME]; + struct param *np; + char *pk, *t, *p, *f; + + strncpy (redir, &result.o_val.v_s[1], SZ_FNAME-1); + redir[SZ_FNAME-1] = EOS; + breakout (redir, &pk, &t, &p, &f); + + /* Task "_" is shorthand for the name of the current package. */ + if (((t == NULL || *t == EOS) && *redir == '.') || + strcmp (t, "_") == 0) + t = pp->p_pfp->pf_ltp->lt_pkp->pk_name; + + np = paramsrch (pk, t, p); + if (np == pp) + cl_error (E_UERR, "self referential indirection on param `%s'", + pp->p_name); + paramget (np, *f); + + } else { + /* Check for indefinite values. */ + if (arrflag && (field == FN_VALUE || field == FN_NULL)) { + if ((result.o_type == OT_BOOL || result.o_type == OT_INT) && + result.o_val.v_i == INDEFL) { + + setopindef (&result); + + } else if (result.o_type == OT_REAL && + result.o_val.v_r == INDEFR) { + + setopindef (&result); + } + } + + pushop (&result); + } +} + + +/* MAKEMODE -- Fill in characters of string s according to which mode bits + * are on in param pp. S should be at least 5 characters long, in the + * (impossible) worse case. + */ +void +makemode ( + struct param *pp, + char *s +) +{ + register int m = pp->p_mode; + + if (m & M_AUTO) + *s++ = PF_AUTO; + if (m & M_QUERY) + *s++ = PF_QUERY; + if (m & M_HIDDEN) + *s++ = PF_HIDDEN; + if (m & M_LEARN) + *s++ = PF_LEARN; + *s = '\0'; +} + + +/* NEWPARAM -- Allocate a new, empty, param on the dictionary and link in + * at end of list of params off pfile *pfp. Put the new entry at the end of + * the list and update pfp->pf_lastpp. + * This is so as to preserve the order in which the params were added to allow + * positional argument matching. + * Null out all unused fields except the three union values. + */ +struct param * +newparam ( + struct pfile *pfp +) +{ + register struct param *newpp; + + newpp = (struct param *) memneed (PARAMSIZ); + + if (pfp->pf_pp == NULL) + pfp->pf_lastpp = pfp->pf_pp = newpp; + else { + pfp->pf_lastpp->p_np = newpp; + pfp->pf_lastpp = newpp; + } + + newpp->p_pfp = pfp; + newpp->p_flags = newpp->p_type = newpp->p_mode = 0; + newpp->p_valo.o_type = newpp->p_mino.o_type = newpp->p_maxo.o_type = 0; + newpp->p_name = newpp->p_prompt = nullstr; + newpp->p_listval = NULL; + newpp->p_listfp = NULL; + newpp->p_lenval = 0; + newpp->p_np = NULL; + + return (newpp); +} + + +/* PARAMSRCH -- Hunt for and return pointer to param in given package and ltask. + * If no ltask specified, use standard search path, ie, check the params for + * the current ltask, then the current package, then the cl. + * Else find pfile for the given ltask, reading it in if it's not in core. + * do not accept the ltask name if it's not defined. + * If the param is list-structured, open the list file if it isn't already + * and P_LEOF is not set; thus, paramget() should close the list file + * and set P_LEOF when it sees EOF and leave it set so we can't open + * it again. Do done of this if we just want the .value field. + * If dealing with a task that has no param file, try to satisfy the request + * from positional args. If that fails, make one that will query. + * Positional args were made named $n by posargset, or the like, and are + * accessed by name. A named reference returns the next (as counted in + * pf_n) positional arg so two references by the same name will not return + * the same value. However, if there are no more positional args, then + * one is made and will cause a query to the same param on each reference. + * Call error() and do not return if cannot find it. + */ +struct param * +paramsrch ( + char *pkname, + char *ltname, + char *pname +) +{ + register struct param *pp; + struct pfile *pfp; + struct param *lookup_param(); + + /* First search for a regular parameter. If this fails then we + * handle the case when currentask has no pfile. + */ + pp = lookup_param (pkname, ltname, pname); + + if (currentask->t_pfp->pf_flags & PF_FAKE) { + if (((XINT)pp == ERR || pp == NULL) && *pname != '$') { + /* If dealing with a task that has no param file, try to + * satisfy the request from positional args. If that fails, + * make one that will query. + */ + pfp = currentask->t_pfp; + pp = paramfind (pfp, (char *)NULL, pfp->pf_n++, NO); + + if (pp == NULL) { + pp = newfakeparam (pfp, pname, 0, OT_STRING, SZ_FNAME); + pp->p_mode |= M_QUERY; + + /* If, instead, we query and set P_OK, a prompt will not + * be generated again if the same param is rereferenced. + * That's great but problem is that satisfying from + * positional args cannot work like this since the name + * isn't saved. + query (pp); + popop(); + pp->p_flags |= P_OK; + */ + } + } + } + + if ((XINT)pp == ERR) + cl_error (E_UERR, e_nopfile, ltname); + if (pp == NULL) + cl_error (E_UERR, e_pnonexist, pname); + + return (pp); +} + + +/* DEFPAR -- Determine if the named parameter exists. Name may include + * package, task and param names, task and param names, or just the param name, + * with appropriate searching as necessary. False is returned if either the + * task has no param file or the param does not exist. + */ +int +defpar (char *param_spec) +{ + char sbuf[SZ_LINE]; + char *pkname, *ltname, *pname, *junk; + + strcpy (sbuf, param_spec); + breakout (sbuf, &pkname, <name, &pname, &junk); + + switch ((XINT) lookup_param (pkname, ltname, pname)) { + case NULL: + case ERR: + return (NO); + default: + return (YES); + } +} + + +/* DEFVAR -- Determine if the named environment variable exists. + */ +int +defvar (char *envvar) +{ + char sbuf[SZ_LINE]; + + if (c_envfind (envvar, sbuf, SZ_LINE) <= 0) + return (NO); + else + return (YES); +} + + +/* LOOKUP_PARAM -- Hunt for and return pointer to param in given package + * and ltask. If task does not have param file, NULL is returned. If pfile + * exists but is not loaded, it is loaded before searching for parameter. + * Returns valid pp if sucessful; NULL if param file exists but contains no + * such param, and ERR if there is no param file. + * All other problems (package, task unknown or ambiguous) result in an abort. + * Called by PARAMSRCH and by DEFPAR. + */ +struct param * +lookup_param ( + char *pkname, + char *ltname, + char *pname +) +{ + register struct param *pp; + register struct package *pkp; + register struct ltask *ltp; + struct pfile *pfp; + struct pfile *pfiles[64]; + struct param *candidate; + int ambig, npfiles, i; + + pp = NULL; + + if (*ltname == '\0') { + /* No ltask or package given so check standard places. If the + * current task is cl the search order is curpack,cl. Otherwise, + * the search order is curtask,package,cl, where `package' is + * the package to which the current task belongs, NOT the current + * package. The current task is the task which is currently + * executing; while a task is executing, any psets referenced + * by the main task pfile are loaded and linked into a list off + * the main pfile. Note that this also hold for the pkg pfile, + * since the pkg-task is always executing while any tasks therein + * are executing (unless the pkg script exits with a keep()). + */ + npfiles = 0; + if (currentask->t_ltp == firstask->t_ltp) { + /* The current task is the cl() task. + */ + pfiles[npfiles++] = NULL; + pfiles[npfiles++] = curpack->pk_pfp; + + } else { + /* The current task is a normal compiled or script task. + * Search the main pfile for the task, any pset-files + * referenced by the main pfile, and lastly the package pfile + * and any pset-files referenced by the package pfile. + */ + struct pfile *pfp_head[2]; + int i; + + pfp_head[0] = currentask->t_pfp; + pfp_head[1] = currentask->t_ltp->lt_pkp->pk_pfp; + + for (i=0; i <= 1; i++) + if ((pfp = pfp_head[i]) != NULL) { + pfiles[npfiles++] = pfp; + if (pfp->pf_flags & PF_PSETREF) + while ((pfp = pfp->pf_npset)) { + pfiles[npfiles++] = pfp; + if (npfiles >= 62) + cl_error (E_IERR, + "lookup_param: too many pfiles"); + } + } + } + + pfiles[npfiles++] = firstask->t_pfp; /* firstask == cl */ + + /* Search for the named parameter in all the pfiles in the search + * path. If an exact match is found in any pfile we are done. + * If abbreviations are enabled and a non-unique abbreviation is + * indicated, keep searching pfiles and abort only if an exact + * match is not found in some other pfile. + */ + candidate = NULL; + ambig = 0; + for (i=0; i < npfiles; i++) { + pfp = pfiles[i]; + if (pfp != NULL && (pp=paramfind (pfp, pname, 0, NO)) != NULL) { + if ((XINT)pp == -1) { + ambig++; + } else if (!strcmp (pp->p_name, pname)) { + ambig = 0; + break; /* exact match */ + } else if (candidate != NULL && candidate != pp) { + ambig++; + } else { + candidate = pp; + } + } + } + + if (ambig) + cl_error (E_UERR, e_pambig, pname, ""); + else if (pp == NULL) + pp = candidate; + + } else { + if (*pkname != '\0') { + /* If the package name is given, search only that package. + */ + pkp = pacfind (pkname); + if ((XINT)pkp == ERR) + cl_error (E_UERR, e_pckambig, pkname); + if (pkp == NULL) + cl_error (E_UERR, e_pcknonexist, pkname); + + /* Search for ltask; it must exist and the given name must + * be an unambiguous abbreviation. + */ + ltp = ltaskfind (pkp, ltname, 1); + if (ltp == NULL) + cl_error (E_UERR, e_tnonexist, ltname); + if ((XINT)ltp == ERR) + cl_error (E_UERR, e_tambig, ltname); + + } else { + /* Ltask name given but not package name. Do circular search + * for ltask; abort if not found or ambiguous. + */ + ltp = ltasksrch ("", ltname); + } + + /* Get param file pointer and find parameter. Return ERR if no + * pfile. + */ + if ((pfp = pfilefind (ltp)) == NULL) { + if (ltp->lt_flags & LT_PFILE) + pfp = pfileload (ltp); + else /* no pfile */ + return ((struct param *)ERR); + } + pp = paramfind (pfp, pname, 0, NO); + if ((XINT)pp == ERR) + cl_error (E_UERR, e_pambig, pname, ltp->lt_lname); + } + + return (pp); +} + + +/* PRINTPARAM -- Convert the info in param pp to text and print it on + * file fp. Return ERR if have a write error, else OK. + * Don't write M_FAKE params unless we are writing to stderr. + * Put quotes around strings; convert escape chars into escape sequences. + * Don't call error() so caller can have a chance to close the file. + */ +int +printparam ( + struct param *pp, + register FILE *fp +) +{ + register int type, bastype; + register char *bp; + char *index(); + char buf[20]; + int arrflag; + int size_arr; + int i; /* a misc variable. */ + + if ((pp->p_mode & M_FAKE) && fp != stderr) + return (OK); + + type = pp->p_type; + bastype = type & OT_BASIC; + arrflag = type & PT_ARRAY; + + + /* NAME */ + fputs (pp->p_name, fp); + fputc (PF_DELIM, fp); + + + /* TYPE */ + bp = buf; + if (type & PT_LIST) + *bp++ = '*'; + else if (arrflag) + *bp++ = 'a'; + + switch (bastype) { + case OT_BOOL: + *bp++ = 'b'; + break; + case OT_INT: + *bp++ = 'i'; + break; + case OT_REAL: + *bp++ = 'r'; + break; + case OT_STRING: + *bp++ = 's'; + break; + } + + /* Overwrite the string descriptor that appears with PT_FILNAM, + * PT_STRUCT and the cursors. + */ + if (type & PT_FILNAM) { + *--bp = 'f'; + if (type & PT_FBIN) + *++bp = 'b'; + if (type & PT_FNOE) + *++bp = 'n'; + if (type & PT_FER) + *++bp = 'r'; + if (type & PT_FTXT) + *++bp = 't'; + if (type & PT_FEW) + *++bp = 'w'; + *++bp = '\0'; + + } else if (type & PT_STRUCT) { + strcpy (--bp, "struct"); + } else if (type & PT_GCUR) { + strcpy (--bp, "gcur"); + } else if (type & PT_IMCUR) { + strcpy (--bp, "imcur"); + } else if (type & PT_UKEY) { + strcpy (--bp, "ukey"); + } else if (type & PT_PSET) { + strcpy (--bp, "pset"); + } else + *bp = '\0'; + + fputs (buf, fp); + fputc (PF_DELIM, fp); + + + /* MODE */ + makemode (pp, buf); + fputs (buf, fp); + fputc (PF_DELIM, fp); + + /* VALUE. + * Set i if pp is a struct or cursor. + * Print the max length of structs or cursors even if they are not + * defined. + */ + i = type & (PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY); + if (opindef(&pp->p_valo) && !i) { + fputs (indefstr, fp); + } else if (opundef(&pp->p_valo) && !i) { + ; + } else if (type & (PT_LIST|PT_FILNAM|PT_PSET)) { + /* Put quotes around string, may contain special chars */ + qputs (pp->p_val.v_s, fp); + } else if (bastype == OT_STRING && !arrflag) { + if (i) + /* -1 to allow for +1 added for \0 in addparam(). */ + fprintf (fp, "%d", pp->p_lenval - 1); + else { + /* Quote string, may contain special chars */ + qputs (pp->p_val.v_s, fp); + } + } else if (arrflag) { + /* Print array descriptor info, and get size of array for + * printing values later. + */ + int dim, d; + short *lenoff; + + size_arr = 1; + dim = pp->p_val.v_a->a_dim; + lenoff = & (pp->p_val.v_a->a_len) ; + fprintf (fp,"%d,", dim); + for (d=0; d<2*dim; d++) { + if (d%2 == 0) + size_arr *= *lenoff; + fprintf(fp, "%d,", *lenoff++); + } + + /* Terminate the line. */ + fprintf(fp, "\\\n"); + + } else + fprop (fp, &pp->p_valo); + + if (!arrflag) + fputc (PF_DELIM, fp); + + /* MINIMUM. + * Set i if this param has a min/max field. reuse in max printing. + */ + i = (bastype != OT_BOOL && + !(type & (PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY|PT_PSET))); + if (pp->p_flags & P_IMIN) + fputs (indefstr, fp); + else if (pp->p_flags & P_UMIN) + ; + else if (i) + fprop (fp, &pp->p_mino); + fputc (PF_DELIM, fp); + + + /* MAXIMUM */ + if (pp->p_flags & P_IMAX) + fputs (indefstr, fp); + else if (pp->p_flags & P_UMAX) + ; + else if (i) + fprop (fp, &pp->p_maxo); + fputc (PF_DELIM, fp); + + + /* PROMPT. */ + if (*pp->p_prompt != '\0') + qputs (pp->p_prompt, fp); + if (!arrflag) + fputc ('\n', fp); + else + fprintf (fp, ",\\\n"); + + /* Structs and cursors get printed on their own line. + */ + if (!(type & PT_LIST) && + (type&(PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY))) { + + if (opindef (&pp->p_valo)) + fputs (indefstr, fp); + else if (opundef (&pp->p_valo)) + ; + else + fputs (pp->p_val.v_s, fp); + fputc ('\n', fp); + } + + if (arrflag) { + /* For a first approximation use a fixed number of + * values per line. + */ + int count, lcount, n_per, *p_i; + double *p_r; + char **p_s; + + if (bastype == OT_BOOL) { + n_per = 20; + p_i = pp->p_aval.a_i; + } else if (bastype == OT_INT) { + n_per = 10; + p_i = pp->p_aval.a_i; + } else if (bastype == OT_REAL) { + n_per = 4; + p_r = pp->p_aval.a_r; + } else if (bastype == OT_STRING) { + n_per = 2; + p_s = pp->p_aval.a_s; + } + + count = 0; + lcount = 0; + + for (; count n_per) { + fprintf(fp, "\\\n"); + lcount = 0; + } + if (bastype == OT_BOOL) { + if (*p_i != INDEFL) { + if (*p_i++) + fprintf (fp, "yes"); + else + fprintf (fp, "no"); + } else + p_i++; + + } else if (bastype == OT_INT) { + if (*p_i == INDEFL) + p_i++; + else + fprintf (fp, "%d", *p_i++); + + } else if (bastype == OT_REAL) { + if (*p_r == INDEFR) + p_r++; + else + fprintf (fp, "%g", *p_r++); + + } else if (bastype == OT_STRING) { + /* The undefined string is the null string, so + * we needn't check for it. + */ + qputs (*p_s++, fp); + } + + if (count < size_arr-1) + fprintf (fp, ","); + else + fprintf (fp, "\n"); + } + } + + if (ferror (fp)) + return (ERR); + + return (OK); +} + + +/* QPUTS -- Print a string on the output stream, converting all recognized + * control characters (newline, tab, and string delimiters) into escape + * sequences, so that they can later be read back in unmodified. + */ +void +qputs ( + register char *str, + register FILE *fp +) +{ + register char ch; + + fputc ('"', fp); + while ((ch = *str++) != '\0') { + switch (ch) { + case '\n': + fputs ("\n", fp); /* avoid super long lines */ + break; + case '\t': + fputs ("\\t", fp); + break; + case '\r': + fputs ("\\r", fp); + break; + case '\f': + fputs ("\\f", fp); + break; + case '\\': + fputc ('\\', fp); + ch = *str++; + fputc (ch, fp); + break; + case '\'': + fputs ("\\'", fp); + break; + case '"': + fputs ("\\\"", fp); + break; + default: + fputc (ch, fp); + } + } + fputc ('"', fp); +} + + +/* PVALDEFINED -- Decide whether string s is indefinite (one of indefstr or + * indeflc) or undefined (s == undefval), and set pp->p_type bits accordingly. + * Return YES if neither of these conditions exist, else NO. Note that + * the null string a null string per se does not qualify as an undefined + * value. + */ +int +pvaldefined ( + struct param *pp, + char *s +) +{ + int val; + + val = NO; + if (s == NULL || s == undefval) + setopundef (&pp->p_valo); + else if (!strcmp (s, indefstr) || !strcmp (s, indeflc)) + setopindef (&pp->p_valo); + else + val = YES; + return (val); +} + + +/* NEWFAKEPARAM -- Make a fake parameter off pfp. Use newparam to actually + * allocate space. If name is NULL, name the parameter $pos, else name it + * name. Add one to pos because users see names as one-indexed. + * Type of param is type; if OT_STRING allocation is for SZ_FNAME characters. + * Check for pos > 99 as we only allowing room for 2 digits in $name for. + * Check for both kinds of null strings, just in case. + */ +struct param * +newfakeparam ( + struct pfile *pfp, + char *name, + int pos, + int type, + int string_len /* if new param is type string, size of string */ +) +{ + register struct param *pp; + + pp = newparam (pfp); + if (name == NULL || *name == '\0') { + if (++pos > 99) + cl_error (E_UERR, "too many fake positional params"); + pp->p_name = memneed (btoi(4)); /* need room for "$nn\0" */ + sprintf (pp->p_name, "$%d", pos); + } else + pp->p_name = comdstr (name); + + if (cldebug) + eprintf ("adding fake param `%s', type code %d\n", + pp->p_name, type); + + type &= OT_BASIC; + pp->p_valo.o_type = type; + pp->p_mino.o_type = type; + pp->p_maxo.o_type = type; + + if (type == OT_STRING) { + /* Allocate specified amount of space, add the eos and init + * max length. Other types need no initialization. + */ + pp->p_val.v_s = memneed (btoi(string_len+1)); + pp->p_val.v_s[string_len] = '\0'; /* the permanent eos. */ + pp->p_lenval = string_len+1; + } + + pp->p_type = type; + pp->p_valo.o_type = OT_UNDEF; + pp->p_mode = M_FAKE; + pp->p_flags = (P_UMIN|P_UMAX); + + return (pp); +} + + +/* GETOFFSET -- Getoffset returns the offset from the beginning of the array + * for using the index values stored on the stack. + */ +int +getoffset ( + struct param *pp +) +{ + int dim, offset, index; + short *plen, *poff, len, off; + + if (mode_offset == DIRECT_OFFSET) { + n_indexes--; + if (n_indexes < 0) + cl_error(E_UERR, e_indexunf); + offset = pop() ; + mode_offset = INDEX_OFFSET; + + } else { + dim = pp->p_val.v_a->a_dim; + plen = &(pp->p_val.v_a->a_len) ; + poff = plen + 1; + + offset = 0; + + while (dim-- > 0) { + len = *(plen + 2*dim); + off = *(poff + 2*dim); + + if (offset > 0) + offset *= len; + + n_indexes--; + if (n_indexes < 0) + cl_error(E_UERR, e_indexunf); + + index = pop(); + + + if (index < off || index > off+len-1) + cl_error(E_UERR, "Array subscript error. Index %d is %d.", + dim+1, index); + offset += index-off; + + } + } + + return (offset); +} + + +/* OFFSETMODE -- Offsetmode() permits the user to choose whether to calculate + * the offsets using an index list, or to push the offset onto the stack + * directly. + */ +void +offsetmode (int mode) +{ + if (mode) + mode_offset = DIRECT_OFFSET; + else + mode_offset = INDEX_OFFSET; +} + + +/* SIZE_ARRAY -- Get the number of elements in an array. + */ +int +size_array ( + struct param *pp +) +{ + int dim, d, size; + short *len; + + size = 1; + + if (pp->p_type & PT_ARRAY ) { + dim = pp->p_val.v_a->a_dim; + len = &(pp->p_val.v_a->a_len) ; + + for (d=0; d < dim; d++) + size *= *(len+2*d); + } + + return (size); +} diff --git a/pkg/cl/param.h b/pkg/cl/param.h new file mode 100644 index 00000000..4e9d8118 --- /dev/null +++ b/pkg/cl/param.h @@ -0,0 +1,220 @@ +/* + * PARAM.H -- In-core broken-out form of parameter file ("pfile") entry. + * main line is a list of pfile structs, one per parameter file, starting + * at parhead; these each head a list of params found in that file. + * + * USES operand.h and config.h + */ + +/* ---------- + * reference chart showing how + * the bits in p_type are set and the p_val/p_min/p_max fields are used for + * various kinds of parameter "type" specs possible in a parameter file. + + +all legal p_type bit val/min/max fields: which v_x and its meaning + combinations spec as +OT_XXXX PT_XXXX written +B I R S L F S/C A p_val p_min p_max in file +- - - - - - - - --------------- --------------- --------------- ------- +x v_i, bool - - b + x v_i, int v_i, min val v_i, max val i + x v_r, real v_r, min val v_r, max val r + x v_s, string - v_i, max length s +x x v_a, bool arr. - - ab + x x v_a, int arr. v_i, min val v_i, max val ai + x x v_a, real arr. v_r, min val. v_r, max val ar + x x v_a, str. arr. - v_i, max length as +x x v_s, fname - *b + x x v_s, fname v_i, min val* v_i, max val* *i + x x v_s, fname v_r, min val* v_r, max val* *r + x x v_s, fname - - *s + x x v_s, fname v_s, min fname v_s, max fname f + x x x v_s, fname v_s, min fname* v_s, max fname* *f + x x v_s, struct - v_i, max length struct + x x x v_s, fname - *struct + + +Notes: +1) S/C refers to any one of PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY|PT_PSET; their + param representation is identical. Similarly, the file spec "struct" may + be gcur, imcur, pset, ukey, or pset. +2) * min/max applies to contents of list file after it is read and converted + to the given base type, not to p_val. +3) "fname" means exactly MAXFILNAM chars are allocated, in-line, with + the parameter regardless of how many are used. there is a permanent '\0' + at v_s[MAXFILNAM-1]. +4) note that PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY|PT_PSET|PT_FILNAM all imply + OT_STRING but that, among these, only PT_FILNAM have ranges. They may be + considered qualifiers of OT_STRING. +5) the max length of a list entry is always MAXLIN. +6) these are not all the same as in the parameter file, such as struct + length being stored in p_max. these must be properly placed when handling + *.field param requests and when printing the in-core param structs back out. +7) min and max fields for arrays refer to all elements within the array. +8) only the scalar types bool, int, real and string may be arrays, and + arrays may not be list-directed. +9) for a string array, the array is a list of pointers. +*/ + +#define PF_INDIRECT ')' /* indirection metacharacter, ")param" */ +#define PF_DELIM ',' /* field delimiter within pfile */ +#define PF_MAXLIN (132+2) /* max pfile line length, plus \n \0 */ +#define PF_COMMENT '#' /* starts a line of comment */ +#define PF_NFIELDS 7 /* number of fields in a pfile line */ +#define PF_NOSTRUCT '*' /* next line is NOT struct initialization*/ +#define PF_SZMINSTR 160 /* p_min field for string type params */ +#define PF_SZMAXSTR 64 /* p_max field for string type params */ + +struct param { + char *p_name; /* name of parameter */ + struct pfile *p_pfp; /* pointer back to pfile */ + int p_type; /* type bits; see below */ + int p_mode; /* bit-packed mode fields. see below. */ + struct operand p_valo; /* value; or length if struct, file if list*/ + struct operand p_mino; /* p_val min and */ + struct operand p_maxo; /* max values */ + char *p_prompt; /* prompt string */ + FILE *p_listfp; /* if PT_LIST: fp of list file, if open */ + char *p_listval; /* buffer for list element (SZ_LINE) */ + struct param *p_np; /* pointer to next param, or NULL */ + short p_flags; /* see p_flags below */ + short p_lenval; /* buflen of p_valo.o_val.v_s if string */ +}; + +/* Shorthand for referencing the values of the value, min, and max + * fields. e.g. p_val.v_s = *char + */ +#define p_val p_valo.o_val +#define p_min p_mino.o_val +#define p_max p_maxo.o_val +#define p_aval p_valo.o_val.v_a->a_ptr + + +/* names of bits in p_type. + * these describe more information about the parameter. + * lower 4 bits are same as for operands; see operand.h. + */ +#define PT_LIST 0000020 /* values are in a file, not in pfile */ +#define PT_FILNAM 0000040 /* string is a bonafide filename */ +#define PT_STRUCT 0000100 /* used for structs */ +#define PT_GCUR 0000200 /* graphics cursor values structure */ +#define PT_IMCUR 0000400 /* image cursor values structure */ +#define PT_UKEY 0001000 /* user keystroke values sructure */ +#define PT_PSET 0002000 /* parameter set pointer parameter */ + +/* attributes if PT_FILNAM */ +#define PT_FER 0004000 /* file must exist and be readable */ +#define PT_FEW 0010000 /* " writable */ +#define PT_FNOE 0020000 /* file must not exist */ +#define PT_FTXT 0040000 /* file is a text file */ +#define PT_FBIN 0100000 /* " binary " */ + +#define PT_ARRAY 0200000 /* parameter is an array */ + +/* names of mode bits in p_mode. + */ +#define M_AUTO 0001 /* auto mode: be as quiet as possible */ +#define M_QUERY 0002 /* query: ask user about value */ +#define M_HIDDEN 0004 /* hidden: param normally not visible */ +#define M_LEARN 0010 /* learn: write out local copy when done*/ +#define M_MENU 0020 /* menu: call eparam at exec time */ +#define M_FAKE 0040 /* never flush this param to a pfile */ +#define M_LOCAL 0100 /* Local var, not param. */ + + +/* p_flags bits. + * misc characteristics of the parameter. + * see pfilecopy() and pfcopyback() for details of P_SET/CLSET/QUERY. + */ +#define P_IMIN 0001 /* min value is indefinite */ +#define P_UMIN 0002 /* min value is undefined */ +#define P_IMAX 0004 /* max value is indefinite */ +#define P_UMAX 0010 /* max value is undefined */ +#define P_LEOF 0020 /* set when see eof on list file */ +#define P_SET 0040 /* set in explicit assignment statement */ +#define P_CLSET 0100 /* set on command line of task */ +#define P_QUERY 0200 /* set from a query */ +#define P_CL 0400 /* parameter is a CL parameter */ + +/* mode code letters in param file; recognized in either case */ +#define PF_AUTO 'a' +#define PF_QUERY 'q' +#define PF_HIDDEN 'h' +#define PF_LEARN 'l' +#define PF_MENU 'm' + +/* ---------- + * one per loaded parameter file. + * the ltask at ltp is used to get the param file's name (ltp->lt_lname), + * its directory (osdir(lt_pname)), and package prefix (lt_pkp->pk_name). + * pf_n use varies. always incremented for each command line argument set by + * posargset, etal. LT_BUILTIN tasks then use it directly to determine how + * many params there are since $nargs is not added in that case. other + * PF_FAKE pfiles use it to create $nargs then reset it to 0 and use it + * to count each unmatched param reference that is satisfied by a postional + * arg (see paramsrch). Other than to set $nargs, it is unused by tasks that + * do not have fake pfiles. + * N.B. the way restor() is written, it is important that a param list is + * never created with some params above and some below its task's topd. + */ +struct pfile { + struct pfile *pf_npf; /* ptr to next pfile, else NULL */ + struct pfile *pf_oldpfp; /* ptr to old pfile, if copy */ + struct ltask *pf_ltp; /* ptr to this pfile's ltask */ + struct pfile *pf_npset; /* ptr to next pset in group */ + struct param *pf_psetp; /* ptr to pset-param if pset */ + struct param *pf_pp; /* ptr to first params */ + struct param *pf_lastpp; /* last param off pfile */ + short pf_n; /* no. of params; see above */ + short pf_flags; /* see flags below */ + char pf_pfilename[SZ_FNAME+1]; /* file to be updated */ +}; + +/* pf_flags */ +#define PF_UPDATE 001 /* at least one param has P_SET set */ +#define PF_FAKE 002 /* made on the fly for an ltask without + * a pfile. should never be written out. + */ +#define PF_COPY 004 /* this is only the working copy of tasks + * pfile; it is never to be written out. + */ +#define PF_PSETREF 010 /* pfile contains a pset parameter */ + +/* size of param and pfile structs, IN INTS, for proper dictionary control. + */ +#define PARAMSIZ btoi (sizeof (struct param)) +#define PFILESIZ btoi (sizeof (struct pfile)) + +/* Variable types used in parsing of declaration types. + */ +#define V_BOOL 0 +#define V_INT 1 +#define V_REAL 2 +#define V_STRING 3 +#define V_GCUR 4 +#define V_IMCUR 5 +#define V_UKEY 6 +#define V_PSET 7 +#define V_STRUCT 8 +#define V_FILE 9 + + +char *nextfield(); /* cracks next pfile line field */ +char *makelower(); /* upper to lower, in place and return */ + +struct param *paramfind(); /* searches for a param on a given pfile*/ +struct param *paramsrch(); /* search, make sure param is there */ +struct param *lookup_param(); /* search standard path for a param */ +struct param *newparam(); /* allocate and link a new param */ +struct param *addparam(); /* make a new param off given pfile */ +struct param *newfakeparam(); /* add a fake param to pfile */ +struct pfile *pfilesrch(); /* read named pfile or ltask pfile */ +struct pfile *pfileload(); /* load pfile for ltask into memory */ +struct pfile *pfileread(); /* read and make params from a pfile */ +struct pfile *pfilefind(); /* look for pfile with given name */ +struct pfile *newpfile(); /* add a new pfile off parhead */ +struct pfile *pfilecopy(); /* make an in-core copy of a pfile */ + +int defpar(); /* determine whether param exists */ +int defvar(); /* determine whether envvar exists */ diff --git a/pkg/cl/pfiles.c b/pkg/cl/pfiles.c new file mode 100644 index 00000000..d116017c --- /dev/null +++ b/pkg/cl/pfiles.c @@ -0,0 +1,1991 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_finfo +#define import_stdio +#define import_ctype +#include + +#include "config.h" +#include "errs.h" +#include "operand.h" +#include "mem.h" +#include "param.h" +#include "task.h" +#include "grammar.h" +#include "proto.h" + + +/* + * PFILES -- Parameter file access procedures. + */ + +extern int cldebug; +extern char *undefval; +extern char *nullstr; +extern char *indefstr, *indeflc; +extern FILE *yyin; +char *uparmdir = UPARM; +long filetime(); +static void mapname(); + +extern int c_finfo(); + + +/* NEWPFILE -- Allocate a new pfile on the dictionary and link in at parhead. + * Set pfp->pf_ltp to ltp. Null out all unused fields. Call error() and don't + * return if not enough core. + */ +struct pfile * +newpfile ( + struct ltask *ltp /* ltask descriptor */ +) +{ + register struct pfile *pfp, *head_pfp; + + pfp = (struct pfile *) memneed (PFILESIZ); + head_pfp = reference (pfile, parhead); + if (head_pfp >= pfp) + cl_error (E_IERR, "in newpfile: parhead exceeds topd"); + + pfp->pf_npf = reference (pfile, parhead); + parhead = dereference (pfp); + + pfp->pf_pp = NULL; + pfp->pf_oldpfp = NULL; + pfp->pf_npset = NULL; + pfp->pf_psetp = NULL; + pfp->pf_ltp = ltp; + pfp->pf_flags = 0; + pfp->pf_n = 0; + + return (pfp); +} + + +/* PFILEUNLINK -- Unlink a pfile from the pfile list. + */ +void +pfileunlink ( + register struct pfile *pfp /* pfile to be unlinked */ +) +{ + register struct pfile *npf; + + if ((npf = reference (pfile, parhead)) == pfp) + parhead = dereference (pfp->pf_npf); + else { + while (npf && npf->pf_npf != pfp) + npf = npf->pf_npf; + if (npf) { + if (pfp->pf_npf == npf) + cl_error (E_IERR, "in pfileunlink: circular reference"); + else + npf->pf_npf = pfp->pf_npf; + } + } +} + + +/* PFILEFIND -- Search the list of loaded pfiles for the pfile for a particular + * ltask. Return pfile pointer or NULL. Note that all loaded pfiles are + * linked on a single list regardless of which package or task they belong to. + */ +struct pfile * +pfilefind ( + register struct ltask *ltp /* ltask descriptor */ +) +{ + register struct pfile *pfp; + + for (pfp = reference (pfile, parhead); pfp != NULL; pfp = pfp->pf_npf) + if (pfp->pf_ltp == ltp) + return (pfp); + + return (NULL); +} + + +/* PFILESRCH -- Given a pfile filename or the pathname of an ltask which + * has a pfile, allocate a pfile descriptor and read the pfile into that + * descriptor. + */ +struct pfile * +pfilesrch ( + char *pfilepath /* filename or ltask pathname */ +) +{ + struct pfile *pfp; + + if (cldebug) + eprintf ("pfilesrch %s\n", pfilepath); + + if (is_pfilename (pfilepath)) { + if ((pfp = pfileread (NULL, pfilepath, 0)) == NULL) + cl_error (E_UERR, e_badpfile, pfilepath); + strcpy (pfp->pf_pfilename, pfilepath); + return (pfp); + + } else { + char *x1, *pk, *t, *x2; + struct ltask *ltp; + + breakout (pfilepath, &x1, &pk, &t, &x2); + ltp = ltasksrch (pk, t); + if (!(ltp->lt_flags & LT_PFILE)) + cl_error (E_UERR, e_nopfile, ltp->lt_lname); + if ((pfp = pfilefind (ltp)) != NULL) + return (pfp); /* already in core. */ + + return (pfileload (ltp)); + } +} + + +/* PFILELOAD -- Load the pfile for the ltask pointed to by ltp. The input + * pfile may be the source package pfile (read only), the users UPARM copy + * of the package pfile, or a named user pfile in the case of a pset-task + * reference. Save the filename where the pfile is to be updated in the + * pfile descriptor, for later use by pfileupdate(). Pfiles are always + * updated in UPARM, except in the case of named pfiles, which are updated + * in place. + */ +struct pfile * +pfileload ( + register struct ltask *ltp /* ltask descriptor */ +) +{ + static long sys_ftime = 0; + register struct task *tp; + register struct param *pp; + char usr_pfile[SZ_FNAME+1]; + char pkg_pfile[SZ_FNAME+1]; + char pkgdir[SZ_FNAME+1]; + long usr_ftime, pkg_ftime; + char *ltname, *pkname; + struct pfile *pfp; + char *sval; + + if (cldebug) + eprintf ("pfileload, task %s\n", ltp->lt_lname); + + /* If the ltask operand is a PSET task, the parameter file to be + * read is controlled by the value of a pset parameter of the same + * name as the ltask, in the main parameter set of the most recently + * executed task which includes that pset parameter. If no running + * task references the PSET task then we use the pfile of the PSET + * task itself, i.e., we have a conventional task.param parameter + * reference. + * + * If we make it through this block of code without reading a named + * pfile and exiting, either nothing has happened (the pset was not + * redirected), or the pset was redirected to a different ltask and + * we are still faced with the equivalent problem of mapping an ltp + * into a pfp, but this time without the compilication of PSET + * indirection. + */ + if (ltp->lt_flags & LT_PSET) { + /* Don't use newtask if it is pointing beyond end of stack. */ + tp = (newtask < (struct task *)&stack[topcs]) ? currentask:newtask; + + for ( ; tp != firstask; tp = next_task(tp)) { + pfp = tp->t_pfp; + if (!pfp || !(pfp->pf_flags & PF_PSETREF)) + continue; + + /* Search pfile of currently executing task. + */ + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) + if (pp->p_type & PT_PSET) + if (!strcmp (pp->p_name, ltp->lt_lname)) { + /* Found pset parameter with same name as ltask. + */ + if (opundef (&pp->p_valo)) + sval = ""; + else + sval = pp->p_val.v_s; + + if (*sval == EOS) { + ; /* Null string - no indirection */ + } else if (is_pfilename (sval)) { + /* Named pfile */ + if ((pfp = pfileread (ltp, sval, 0)) != NULL) + return (pfp); + else + cl_error (E_UERR, e_badpfile, sval); + } else { + /* Must be a reference to another task */ + char *x1, *pk, *t, *x2; + + breakout (sval, &x1, &pk, &t, &x2); + ltp = ltasksrch (pk, t); + if (!(ltp->lt_flags & LT_PFILE)) + cl_error (E_UERR, e_nopfile, ltp->lt_lname); + } + + goto epset_; + } + } + } +epset_: + ltname = ltp->lt_lname; + pkname = ltp->lt_pkp->pk_name; + + /* Determine the UPARM filename of the pfile. */ + mkpfilename (usr_pfile, uparmdir, pkname, ltname, ".par"); + + /* As an optimization, all the checking for filetimes, file sizes, + * and out of date pfiles is only performed once when a file is + * first accessed. Once a valid up to date UPARM version of a pfile + * is obtained a bit is set in the ltask descriptor and thereafter + * we need only read the UPARM version of the pfile and exit. If a + * problem occurs reading the pfile, or if the pfile is unlearned, + * the bit is cleared and all the checking and initialization is + * repeated. + */ + if (ltp->lt_flags & LT_UPFOK) + if ((pfp = pfileread (ltp, usr_pfile, 1)) != NULL) + return (pfp); + + /* Get modification (creation) time of usr pfile and filename and + * modification time of pkg pfile. Look for a .par version of the + * pkg pfile, and if not found, a .cl version (procedure script). + */ + usr_ftime = filetime (usr_pfile, "c"); + c_fnldir (ltp->lt_pname, pkgdir, SZ_FNAME); + + mkpfilename (pkg_pfile, pkgdir, pkname, ltname, ".par"); + if ((pkg_ftime = filetime (pkg_pfile, "m")) <= 0) { + mkpfilename (pkg_pfile, pkgdir, pkname, ltname, ".cl"); + if ((pkg_ftime = filetime (pkg_pfile, "m")) <= 0) + cl_error (E_UERR, e_nopfile, ltname); + } + + /* Get the date when the iraf system was last installed or updated. + * This is indicated by the modify time of the special file hlib$utime, + * which is touched during the system installation process. The file + * may actually be newer than the date of system update/install but + * that is harmless. + */ + if (sys_ftime <= 0) + sys_ftime = filetime ("hlib$utime", "m"); + + /* If the system was installed more recently than the package pfile + * was modified, use the system modify time instead. + */ + if (sys_ftime > 0) + if (sys_ftime > pkg_ftime) + pkg_ftime = sys_ftime; + + if (usr_ftime > 0) { + /* We have a user (UPARM) version of the pfile. If it is newer + * than the pkg pfile, use it, else read the pkg pfile and merge + * the param values from the user pfile into the new pkg pfile. + */ + if (usr_ftime>pkg_ftime && (pfp=pfileread(ltp,usr_pfile,1)) != NULL) + ltp->lt_flags |= LT_UPFOK; + else { + if ((pfp = pfileread (ltp, pkg_pfile, 0)) == NULL) + cl_error (E_UERR, e_badpfile, pkg_pfile); + pfilemerge (pfp, usr_pfile); + strcpy (pfp->pf_pfilename, usr_pfile); + } + } else { + /* No user pfile; read pkg pfile. + */ + if ((pfp = pfileread (ltp, pkg_pfile, 0)) == NULL) { + FILE *fp; + if (!is_pfilename (pkg_pfile)) + if ((fp = fopen (pkg_pfile, "r")) != NULL) { + if (!procscript (fp)) + cl_error (E_UERR, e_nopfile, ltname); + fclose (fp); + } + cl_error (E_UERR, e_badpfile, pkg_pfile); + } else + strcpy (pfp->pf_pfilename, usr_pfile); + } + + return (pfp); +} + + +/* PFILEMERGE -- Merge the parameter values from the named (old user) pfile + * into a loaded parameter set. + */ +int +pfilemerge ( + struct pfile *npf, /* loaded parameter set */ + char *opfile /* old parameter file */ +) +{ + register struct param *o_pp, *n_pp, *l_pp; + int bastype; + struct pfile *opf; + struct ltask *ltp; + XINT save_topd; + + if (cldebug) + eprintf ("pfilemerge, task %s, pfile %s\n", + (ltp = npf->pf_ltp) ? ltp->lt_lname : "", opfile); + + /* Open old pfile. */ + save_topd = topd; + if ((opf = pfileread (npf->pf_ltp, opfile, 0)) == NULL) + return (ERR); + + /* For each parameter in the old pfile, locate the corresponding + * parameter in the new pfile and copy the value. No other fields + * of the parameter structure are copied. + */ + for (n_pp = NULL, o_pp = opf->pf_pp; o_pp; o_pp = o_pp->p_np) { + /* Circular search, starting at position of last parameter. + */ + n_pp = ((l_pp = n_pp) != NULL) ? n_pp->p_np : npf->pf_pp; + while (n_pp != l_pp) { + if (n_pp == NULL) + n_pp = npf->pf_pp; + else if (strcmp (n_pp->p_name, o_pp->p_name) == 0) + break; + else + n_pp = n_pp->p_np; + } + + /* If parameter not in new param set or the datatypes do not + * match, skip this parameter. + */ + if (n_pp == l_pp) + continue; + if (n_pp->p_type != o_pp->p_type) + continue; + + bastype = (n_pp->p_type & OT_BASIC); + + /* Copy value */ + n_pp->p_valo.o_type = o_pp->p_valo.o_type; + + /* Handle arrays. */ + /* The array descriptors should remain the same, only + * the stored values could change. + */ + if (n_pp->p_type & PT_ARRAY) { + int dim, d, size_arr; + short *lenoff; + + /* Get size of array. */ + dim = n_pp->p_val.v_a->a_dim; + lenoff = &(n_pp->p_val.v_a->a_len); + size_arr = 1; + if (bastype == OT_REAL) + size_arr = 2; + for (d=0; d < dim; d++) + size_arr *= *(lenoff + 2*d); + + if (bastype != OT_STRING) { + int *p, *q; + p = o_pp->p_aval.a_i; + q = n_pp->p_aval.a_i; + for (d=0; d < size_arr; d++) + *q++ = *p++; + } else { + char **p, **q; + p = o_pp->p_aval.a_s; + q = n_pp->p_aval.a_s; + for (d=0; d < size_arr; d++) + strcpy (*q++, *p++); + } + + } else if (!(o_pp->p_valo.o_type & (OT_INDEF|OT_UNDEF))) { + if (((o_pp->p_valo.o_type & OT_BASIC) == OT_STRING) && + (n_pp->p_val.v_s != NULL)) { + strncpy (n_pp->p_val.v_s, o_pp->p_val.v_s, n_pp->p_lenval-1); + } else + n_pp->p_valo.o_val = o_pp->p_valo.o_val; + } + } + + npf->pf_flags |= PF_UPDATE; + + /* Unlink scratch pfile descriptor and return dictionary space. + */ + pfileunlink (opf); + topd = save_topd; + + return (OK); +} + + +/* PFILEUPDATE -- Update a parameter set in the pfile from which it was + * originally read. Nothing is done unless the parameter set has been + * modified and needs updating, or if we have a fake (in-core) parameter set. + */ +void +pfileupdate ( + struct pfile *pfp /* parameter file descriptor */ +) +{ + if ((pfp->pf_flags & (PF_FAKE|PF_UPDATE)) != PF_UPDATE) + return; + + if (cldebug) + eprintf ("pfileupdate %s\n", pfp->pf_pfilename); + + /* Do not update the CL parameter file; we always read the system + * cl.par file upon startup. + */ + if (pfp->pf_ltp == firstask->t_ltp) + return; + + pfilewrite (pfp, pfp->pf_pfilename); + pfp->pf_flags &= ~PF_UPDATE; + + if (pfp->pf_ltp) + pfp->pf_ltp->lt_flags |= LT_UPFOK; +} + + +/* PFILEREAD -- Allocate a pfile descriptor and read the named pfile into it. + * The input file may be either a parameter file or a CL procedure script. + */ +struct pfile * +pfileread ( + struct ltask *ltp, /* associated ltask */ + char *pfilename, /* parameter file filename */ + int checkmode /* check for "mode" parameter */ +) +{ + register char *ip; + char buf[SZ_LINE+1]; + struct pfile *pfp; + struct param *pp; + int nerrs, gotmode, status, oldlines; + FILE *fp, *yysave; + XINT save_topd; + + if (cldebug) + eprintf ("pfileread, task %s, pfile %s\n", + ltp ? ltp->lt_lname : "", pfilename); + + if ((fp = fopen (pfilename, "r")) == NULL) + return (NULL); + + save_topd = topd; + pfp = newpfile (ltp); + strcpy (pfp->pf_pfilename, pfilename); + + nerrs = 0; + gotmode = 0; + + if (is_pfilename (pfilename)) { + /* Pfile has ".par" filename extension, format is a simple + * list of parameter structs, one parameter per line. + */ + while (fgets (buf, PF_MAXLIN, fp) != NULL) { + /* Skip comment lines and blank lines. + */ + for (ip=buf; (*ip == ' ' || *ip == '\t'); ip++) + ; + if (*ip == PF_COMMENT || *ip == '\n') + continue; + + if ((pp = addparam (pfp, ip, fp)) == NULL) + nerrs++; + else if (!strcmp (pp->p_name, "mode")) { + if (gotmode) { + eprintf ("more than one `mode' param\n"); + nerrs++; + } else + gotmode++; + } + } + + /* When a pfile is udpated in uparm a "mode" parameter is + * always written out as the last parameter to mark the end of + * the parameter list. If checkmode is enabled and the mode + * parameter is not seen, this indicates the the pfile has + * been truncated and should not be used. + */ + if (nerrs > 0 || ferror(fp) || (checkmode && !gotmode)) + goto error_; + + } else if (procscript (fp)) { + extern int yyparse(); + + /* Parse the declarations section of a procedure script. + * The procscript() call leaves us positioned to the procedure + * statement. + */ + parse_state = PARSE_PARAMS; + parse_pfile = pfp; + yysave = yyin; + yyin = fp; + + /* Fool the parser into believing we are at the + * beginning of a script for any error messages + * which come out. + */ + oldlines = newtask->t_scriptln; + newtask->t_scriptln = 0; + + status = yyparse(); + + /* Reset the parse state in case we are in a free script. */ + parse_state = PARSE_FREE; + newtask->t_scriptln = oldlines; + yyin = yysave; + + if (status) + goto error_; + + if (paramfind (pfp, "mode", 0, YES) == NULL) + gotmode = NO; + else + gotmode = YES; + } else + goto error_; + + /* Count the number of parameters. If there are no parameters we + * probably have a zero length file, which is an error. + */ + for (status=0, pp=pfp->pf_pp; pp; pp=pp->p_np) + status++; + if (status == 0) + goto error_; + + /* Add `mode' param. Get the value from the current package + * or from the CL if there is no package pfile. + */ + if (gotmode == 0) { + struct param *qq; + + /* Allocate the param with "ql" as the ultimate default. + */ + pp = addparam (pfp, "mode,s,h,ql\n", fp); + + if (curpack != NULL) { + if (curpack->pk_pfp != NULL) { + qq = paramfind (curpack->pk_pfp, "mode", 0, YES); + if (qq != NULL && qq != (struct param *)ERR) { + strcpy (pp->p_val.v_s, qq->p_val.v_s); + gotmode++; + } + } + } + } + + if (gotmode == 0) /* CL--This should rarely be needed */ + if (firstask->t_modep != NULL) + strcpy (pp->p_val.v_s, firstask->t_modep->p_val.v_s); + + fclose (fp); + return (pfp); + +error_: + fclose (fp); + pfileunlink (pfp); + topd = save_topd; + return (NULL); +} + + +/* PFILEWRITE -- Write out the parameters for given pfile into a file. + * Any existing file is silently clobbered. The filename extension is + * always ".par". + */ +int +pfilewrite ( + struct pfile *pfp, /* pfile descriptor */ + char *pfilename /* file to be written */ +) +{ + register char *ip, *op, *dot; + char pfname[SZ_PATHNAME+1]; + struct param *pp; + int nparams; + FILE *fp; + + if (cldebug) + eprintf ("pfilewrite %s\n", pfilename); + + /* Copy the filename, changing the extension to .par if necessary. + */ + for (dot=NULL, ip=pfilename, op=pfname; (*op = *ip++); op++) + if (*op == '.') + dot = op; + strcpy (dot ? dot : op, ".par"); + + if (cldebug) + eprintf ("writing pfile `%s'\n", pfname); + + /* Delete any existing pfile before updating. + */ + c_delete (pfname); + + /* Disable interrupts while updating the pfile to eliminate the + * possibility of file truncation. The "mode" parameter is always + * written last to mark the end of a valid pfile. + */ + intr_disable(); + nparams = 0; + + if ((fp = fopen (pfname, "w")) == NULL) + eprintf ("Unable to open parameter file `%s'.\n", pfname); + else { + struct param *modepp = NULL; + for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np) { + if (!(pp->p_mode & M_LOCAL)) { + if (!strcmp (pp->p_name, "mode")) { + modepp = pp; + } else if (printparam (pp, fp) == ERR) { + fclose (fp); + cl_error (E_IERR|E_P, + "Error writing local pfile `%s'", pfname); + } else + nparams++; + } + } + + if (modepp) { + printparam (modepp, fp); + nparams++; + } + fclose (fp); + } + + intr_enable(); + return (nparams); +} + + +/* PFILEINIT -- Initialize or "unlearn" a pfile. Look for user version of + * pfile in uparm; if found, delete it. If pfile is loaded, unlink from + * pfile list. Fix up flag bits in ltask descriptor. We are called from + * "unlearn" to restore the package default parameters for an ltask or package. + */ +int +pfileinit ( + struct ltask *ltp +) +{ + struct task *tp; + struct pfile *pfp; + char pfilename[SZ_FNAME]; /* user pfile */ + char pkgdir[SZ_FNAME+1]; + char *ltname; /* name of the new pfile */ + char *pkname; /* name of its package */ + int running; + + if (cldebug) + eprintf ("unlearn pfile for task %s\n", ltp->lt_lname); + + ltname = ltp->lt_lname; + pkname = ltp->lt_pkp->pk_name; + + /* Determine if the pfile belongs to a loaded package or to a task + * which is currently executing. + */ + running = 0; + if (ltp->lt_flags & LT_DEFPCK) + running++; + else { + for (tp=currentask; tp <= firstask; tp = next_task(tp)) + if (tp->t_ltp == ltp) { + running++; + break; + } + } + + /* Delete any "learned" copy of the pfile in uparm. */ + mkpfilename (pfilename, uparmdir, pkname, ltname, ".par"); + c_delete (pfilename); + + /* Clear the flag that says we have a valid user param file. */ + ltp->lt_flags &= ~(LT_UPFOK); + + /* See if the pfile is in core; if so, unlink all copies. If the + * pfile belongs to a currently executing task we can't unlink it, + * so reset the parameter values to the system defaults instead. + */ + while ((pfp = pfilefind (ltp)) != NULL) + if (running) { + c_fnldir (ltp->lt_pname, pkgdir, SZ_FNAME); + mkpfilename (pfilename, pkgdir, pkname, ltname, ".par"); + pfilemerge (pfp, pfilename); + pfp->pf_flags &= ~PF_UPDATE; + if (ltp->lt_flags & LT_DEFPCK) + break; + } else + pfileunlink (pfp); + + return (OK); +} + + +/* IS_PFILENAME -- Test whether a string is a pfile filename, i.e., whether + * or not the string has a ".par" extension. + */ +int +is_pfilename (char *opstr) +{ + register char *ip; + char *dot; + + /* If the named object has a ".par" extension we assume it is a + * pfile filename, otherwise we assume it is an ltask pathname. + */ + for (ip=opstr, dot=NULL; *ip; ip++) + if (*ip == '.') + dot = ip; + + return (dot && strcmp (dot, ".par") == 0); +} + + +/* MKPFILENAME -- Generate a parameter file name, given a directory prefix + * the names of the package and ltask, and the filename extension. The form + * of the filename depends upon whether the pfile is to be stored in UPARM. + * UPARM pfile names have the form "uparm$ // pakltask.par", where `pak' is + * the package prefix, consisting of the first LEN_PKPREFIX-1 characters of + * the package name plus the final character, and `ltask' is the ltask name + * squeezed to LEN_PFILENAME characters. If not writing to UPARM, we just + * use the full filename. + */ +void +mkpfilename ( + char *buf, /* receives output filename */ + char *dir, /* dir name or prefix */ + char *pkname, /* package name */ + char *ltname, /* ltask name */ + char *extn /* filename extension */ +) +{ + char temp[SZ_FNAME+1]; + + strcpy (buf, dir); /* start with directory name */ + + if (strcmp (dir, uparmdir) == 0) { + strcat (buf, "$"); + mapname (pkname, temp, LEN_PKPREFIX); + strcat (buf, temp); + mapname (ltname, temp, LEN_PFILENAME); + strcat (buf, temp); + } else + strcat (buf, ltname); + + strcat (buf, extn); /* add extension for pfile */ +} + + +/* MAPNAME -- Apply the N+1 mapping convention (first N-1 plus last chars) + * to generate a name no longer than N characters. Returns the number of + * characters generated. + */ +static void +mapname ( + char *in, + char *out, + int maxlen +) +{ + register int ip, op; + + ip = 0; + op = 0; + while (op < maxlen-1 && (out[op++] = in[ip++]) != '\0') + ; + if (out[op-1] != '\0') { /* append last char */ + if (in[ip] != '\0') { + while (in[ip] != '\0') + ip++; + out[op++] = in[ip-1]; + } + out[op++] = '\0'; + } +} + + +/* FILETIME -- Get the time of creation or of last modify of a file. If the + * file does not exist or cannot be accessed zero is returned. + */ +long +filetime ( + char *fname, /* file name */ + char *timecode /* "c" or "m" */ +) +{ + struct _finfo fi; + + if (c_finfo (fname, &fi) == ERR) + return (0L); + else { + switch (*timecode) { + case 'c': + return (fi.fi_ctime); + case 'm': + return (fi.fi_mtime); + default: + return (0L); + } + } +} + + +/* PFILECOPY -- Make a new copy of paramfile at pfp for a new task. Command + * line changes, queries and assignments are done to this copy. Link in the + * usual fashion off parhead. Copy all the parameters as well, taking care to + * make new copies of strings and setting pointers in new params to their own + * copies. Return pointer to new entry; no error return. + * Reset P_CLSET, P_SET and P_QUERY flags so pfcopyback() can tell whether + * these events happened for this particular run of the task. + */ +struct pfile * +pfilecopy ( + register struct pfile *pfp +) +{ + register struct param *pp, *newpp; + struct pfile *newpfp; + int bastype; + + if (cldebug) { + if (pfp->pf_ltp) + eprintf ("copying pfile for `%s'\n", pfp->pf_ltp->lt_lname); + else + eprintf ("copying pfile `%s'\n", pfp->pf_pfilename); + } + + newpfp = newpfile (pfp->pf_ltp); + for (pp = pfp->pf_pp; pp; pp = pp->p_np) { + + /* Allocate new parameter */ + newpp = newparam (newpfp); + bastype = pp->p_type & OT_BASIC; + + /* COPY VALUE */ + + newpp->p_valo = pp->p_valo; + + /* Handle arrays. */ + if (pp->p_type & PT_ARRAY) { + struct arr_desc *parrd, *qarrd; + int size_arr; + short *lenoff, *qlenoff; + int dim, d, *pval, *qval; + + parrd = pp->p_val.v_a; + dim = parrd->a_dim; + size_arr = 1; + + lenoff = &(parrd->a_len) ; + for (d=0; d < dim; d++) + size_arr *= *(lenoff + 2*d); + if (bastype == OT_REAL) + size_arr *= 2; + + /* Ready to allocate new descriptor and data block */ + qarrd = (struct arr_desc *)memneed (2 + dim); + newpp->p_val.v_a = qarrd; + + qarrd->a_ptr.a_i = (int *) memneed(size_arr); + + qarrd->a_dim = dim; + qlenoff = &(qarrd->a_len); + for (d=0; d<2*dim; d++) + *qlenoff++ = *lenoff++; + + if (bastype != OT_STRING) { + /* If not string then copy values across. */ + + pval = parrd->a_ptr.a_i; + qval = qarrd->a_ptr.a_i; + for (d=0; d < size_arr; d++) + *qval++ = *pval++; + + } else { + /* Copy strings one by one. */ + + int len; + char **p, **q; + + if (pp->p_maxo.o_type == OT_INT) + len = pp->p_maxo.o_val.v_i; + else + len = SZ_FNAME; + + p = parrd->a_ptr.a_s; + q = qarrd->a_ptr.a_s; + for (d=0; d < size_arr; d++) { + *q = memneed (btoi(len)); + strncpy (*q++, *p++, len-1); + *(q+len-1) = '\0' ; + } + } + + } else if ((pp->p_valo.o_type & OT_BASIC) == OT_STRING) { + /* Regular (i.e. scalar) strings. + */ + newpp->p_val.v_s = memneed (btoi(pp->p_lenval)); + strncpy (newpp->p_val.v_s, pp->p_val.v_s, pp->p_lenval-1); + } + + /* COPY MIN */ + newpp->p_mino = pp->p_mino; + if ((pp->p_mino.o_type & OT_BASIC) == OT_STRING && + !(pp->p_flags & P_UMIN)) { + newpp->p_min.v_s = memneed (btoi (PF_SZMINSTR)); + strncpy (newpp->p_min.v_s, pp->p_min.v_s, PF_SZMINSTR-1); + } + + /* COPY MAX */ + newpp->p_maxo = pp->p_maxo; + if ((pp->p_maxo.o_type & OT_BASIC) == OT_STRING && + !(pp->p_flags & P_UMAX)) { + newpp->p_max.v_s = memneed (btoi (PF_SZMAXSTR)); + strncpy (newpp->p_max.v_s, pp->p_max.v_s, PF_SZMAXSTR-1); + } + + /* COPY PROMPT */ + newpp->p_prompt = comdstr (pp->p_prompt); + + /* Copy all the easy entries last; we made it! */ + newpp->p_name = pp->p_name; + newpp->p_type = pp->p_type; + newpp->p_mode = pp->p_mode; + newpp->p_flags = pp->p_flags & ~(P_CLSET|P_QUERY|P_SET); + newpp->p_listfp = pp->p_listfp; + newpp->p_listval = pp->p_listval; + newpp->p_lenval = pp->p_lenval; + + } + + newpfp->pf_oldpfp = pfp; + strcpy (newpfp->pf_pfilename, pfp->pf_pfilename); + newpfp->pf_flags = (pfp->pf_flags & PF_PSETREF); + newpfp->pf_flags |= PF_COPY; + + return (newpfp); +} + + +/* PFCOPYBACK -- Copy the contents of each param that is to be changed + * permanently in the given pfile to the corresponding param in original + * pfile. Once thus copied, they are considered permanently changed since + * restor() will write out to their pfile. Call the target pfile pft. + * Copy only those params for which P_SET is set or for which P_QUERY or + * P_CLSET is set provided learn mode is on and the param is not M_HIDDEN. + * Since P_SET was cleared by pfilecopy(), it can only be set in the copy + * if it was set since the task started. + * Set PF_UPDATE in pft if, in fact, any copying took place. + * Don't copy at all if the working file is not a copy; this is primarily + * to stop the final copy on eof from the first cl and as a nice safety chk. + * N.B. we assume pff was made from pft with pfilecopy() and so the params are + * in the same order; we also assume none were added. + * + * N.B. After copying, unlink the copy pfile from the pfile list, to insure + * that hidden params modified on the command line are not preserved after + * termination of a task which called KEEP. Restor() will not lop off the + * dead pfile if it is below the new topd set by keep. + */ +void +pfcopyback ( + struct pfile *pff +) +{ + register struct param *pt, *pf; + struct pfile *pft; + int bastype; + int pfflags; + int copy; /* set if a real copy occurred */ + int learn; /* set if learn is on */ + + if (cldebug) + eprintf ("pfcopyback %s\n", pff->pf_pfilename); + + if (!(pff->pf_flags & PF_COPY)) + return; + pft = pff->pf_oldpfp; + + learn = effmode ((struct param *) NULL) & M_LEARN; + copy = 0; + + for (pt=pft->pf_pp, pf=pff->pf_pp; pf&&pt; pt=pt->p_np, pf=pf->p_np) { + pfflags = pf->p_flags; + + /* Always copy back the list file pointer else the list file, if + * opened during task execution, will not be closed. + */ + pt->p_listfp = pf->p_listfp; + + /* Copy param back if it was set in an explicit assignment, + * or if it was set in a query or on the command line, and we are + * in learn mode, and the parameter is not hidden. + */ + if (!((pfflags & P_SET) || ((pfflags&(P_QUERY|P_CLSET)) && learn && + !(pf->p_mode & M_HIDDEN)))) + continue; + + bastype = pt->p_type & OT_BASIC; + copy++; + + /* Don't bother copying name since it couldn't have changed. + * Other fields copy directly. + */ + pt->p_type = pf->p_type; + pt->p_mode = pf->p_mode; + + /* Use all new flags bits but discard CLSET and QUERY and merge + * SET with its original state so either it or the copy can + * cause a permanent change to the parameter. + */ + pt->p_flags &= P_SET; + pt->p_flags |= pfflags & ~(P_CLSET|P_QUERY); + + /* Copy value */ + pt->p_valo.o_type = pf->p_valo.o_type; + + /* Handle arrays. */ + /* The array descriptors should remain the same, only + * the stored values could change. + */ + if (pt->p_type&PT_ARRAY) { + int dim, d, size_arr; + short *lenoff; + + /* Get size of array. */ + dim = pt->p_val.v_a->a_dim; + lenoff = &(pt->p_val.v_a->a_len); + size_arr = 1; + if (bastype == OT_REAL) + size_arr = 2; + for (d=0; dp_aval.a_i; + q = pt->p_aval.a_i; + for (d=0; dp_aval.a_s; + q = pt->p_aval.a_s; + for (d=0; dp_valo.o_type & (OT_INDEF|OT_UNDEF))) { + if (((pf->p_valo.o_type & OT_BASIC) == OT_STRING) && + (pt->p_val.v_s != NULL)) { + strncpy (pt->p_val.v_s, pf->p_val.v_s, pf->p_lenval-1); + } else + pt->p_valo.o_val = pf->p_valo.o_val; + } + + /* Copy min */ + if (!(pf->p_flags & P_UMIN)) { + pt->p_mino.o_type = pf->p_mino.o_type; + if ((pf->p_mino.o_type & OT_BASIC) == OT_STRING && + pt->p_min.v_s != NULL) + strncpy (pt->p_min.v_s, pf->p_min.v_s, PF_SZMINSTR-1); + else + pt->p_mino.o_val = pf->p_mino.o_val; + } + + /* Copy max */ + if (!(pf->p_flags & P_UMAX)) { + pt->p_maxo.o_type = pf->p_maxo.o_type; + if ((pf->p_maxo.o_type & OT_BASIC) == OT_STRING && + pt->p_max.v_s != NULL) + strncpy (pt->p_max.v_s, pf->p_max.v_s, PF_SZMAXSTR-1); + else + pt->p_maxo.o_val = pf->p_maxo.o_val; + } + } + + if (copy) { + if (cldebug) { + if (pff->pf_ltp) { + eprintf ("copied back pfile for `%s'\n", + pff->pf_ltp->lt_lname); + } else + eprintf ("copied back pfile `%s'\n", pff->pf_pfilename); + } + pft->pf_flags |= PF_UPDATE; + } + + /* Unlink pfile to ensure that it never gets reused. + */ + pfileunlink (pff); +} + + +/* ADDPARAM -- Allocate a new param off *pfp and fill with fields derived + * from line buf. + * Buf should have trailing '\n' '\0' as per fgets. + * Set UNDEF for those fields that are left blank, INDEF for those fields + * so indicating. + * FP is used to read a structure, cursor, long quoted string, or arrays. + * Return pointer to new param if ok, else NULL. In order to handle multiple + * errors while reading a param file, we print informative info directly + * here with eprintf. This avoids calling error() and gives us a chance + * to handle a file with multiple errors and find many of them in one pass. + * Besides pfileread(), we are also called from various other places, such as + * execnewtask(), to add such parameters as $nargs and mode. + */ +struct param * +addparam ( + struct pfile *pfp, + char *buf, + FILE *fp +) +{ + static char *minfields = + "must specify at least name,type,mode for `%s'\n"; + static char *nominmax = + "ranges not allowed for struct/cursor/string/bool param `%s'\n"; + static char *umquotes = + "unmatched quotes in %s field for `%s'\n"; + + register struct param *pp; /* new param being filled up */ + register char *s; /* pointer to compiled string. */ + char *pnamehold; /* param's name as soon as we know it */ + int len; /* used to measure string lengths */ + int bastype; /* OT_BASIC part of type as soon as know*/ + int arrflag; /* Is param an array? */ + struct arr_desc *parrd; /* Pointer to array descriptor. */ + int size_arr; /* Size of array. */ + extern double atof(); + char **tbuf; + + pp = newparam (pfp); + + /* P_NAME */ + + pnamehold = ""; + tbuf = &buf; + if ((s = nextfield (tbuf, fp)) == NULL) { + eprintf (minfields, pnamehold); + return (NULL); + } else if (s == (char *)ERR) { + eprintf (umquotes, "name", pnamehold); + return (NULL); + } else + pnamehold = pp->p_name = s; + + + /* P_TYPE */ + + if ((s = nextfield (tbuf, fp)) == NULL) { + eprintf (minfields, pnamehold); + return (NULL); + } else if (s == (char *)ERR) { + eprintf (umquotes, "type", pnamehold); + return (NULL); + } else { + if (strcmp (s, "pset") == 0) + pfp->pf_flags |= PF_PSETREF; + if ((pp->p_type = scantype (s)) == ERR) { + eprintf (" in `%s'\n", pnamehold); + return (NULL); + } + } + bastype = pp->p_type & OT_BASIC; + arrflag = pp->p_type & PT_ARRAY; + + /* P_MODE */ + + if ((s = nextfield (tbuf, fp)) == NULL) { + eprintf (minfields, pnamehold); + return (NULL); + } else if (s == (char *)ERR) { + eprintf (umquotes, "mode", pnamehold); + return (NULL); + } else if ((pp->p_mode = scanmode (s)) == ERR) { + eprintf (" in `%s'\n", pnamehold); + return (NULL); + } + + + /* P_VAL */ + + pp->p_valo.o_type = bastype; + + if ((s = nextfield (tbuf, fp)) == (char *)ERR) { + eprintf (umquotes, "value", pnamehold); + return (NULL); + } + + if (pp->p_type & (PT_LIST|PT_FILNAM|PT_PSET)) { + pp->p_val.v_s = memneed (btoi(SZ_FNAME)); + pp->p_val.v_s[SZ_FNAME-1] = '\0'; + pp->p_lenval = SZ_FNAME; + + if (pvaldefined (pp, s)) { + char *p; + + /* Change a whitespace-only filename into a null string; this + * makes it easier for users to check null filenames in + * scripts. It makes sense anyway since these are invalid + * filenames. + */ + p = s; + while (*p == ' ' || *p == '\t') + p++; + if (*p == '\0' || *p == '\n') + pp->p_val.v_s[0] = '\0'; + else + strncpy (pp->p_val.v_s, s, SZ_FNAME-1); + } else + *pp->p_val.v_s = '\0'; + + if (pp->p_type & PT_LIST) + pp->p_listval = memneed (btoi(SZ_LINE)); + pp->p_valo.o_type = OT_STRING; + + } else if (pp->p_type & (PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY)) { + + /* Non-list structs read next line and store at p_val.v_s + * unless the length field begins with a PF_NOSTRUCT. + * The storage allocated in the dictionary, and pointed to by + * p_val.v_s, is the max of the number in the value field and + * the length of the structure init string, on the next line. + * it is an error for the init string to be longer than the + * length given, if any, or for either to be greater than + * SZ_LINE-2. + * SZ_LINE-2 is the default length if neither a len not init is + * given. + * OT_INDEF/UNDEF refer to p_val; p_lenval always set to length + * (max length) of value string if value is a string. + * Nextfield() compiles the length spec into the dictionary; + * it's short and not worth trying to dig out... + */ + + int readinit = 0; /* 1 if init is in next ln */ + + if (s == NULL) { + readinit++; + len = SZ_LINE-1; /* supply default */ + } else { + if (*s == PF_NOSTRUCT) + s++; + else + readinit++; + + len = atoi (s); + if (len <= 0) + len = SZ_LINE-1; /* supply default */ + else if (len > SZ_LINE-1) { + eprintf ("`%s' struct lengths limited to %d\n", + pnamehold, SZ_LINE-1); + return (NULL); + } + } + len++; /* allow for \0 */ + + if (readinit) { + /* Initialize with next line. Lots of pathology here... + */ + char initbuf[SZ_LINE]; + int initlen; + + if (fgets (initbuf, SZ_LINE, fp) == NULL) { + eprintf ("`%s' has no initialized\n", + pnamehold); + return (NULL); + } + + initlen = strlen (initbuf); /* includes \n, if present */ + + if (initbuf[initlen-1] == '\n') + initbuf[initlen-1] = '\0'; + else { + int c; + eprintf ("`%s' initialization too long\n", + pnamehold); + while ((c = fgetc(fp)) != '\n' && c != EOF) + ; + return (NULL); + } + + if (initlen > len) { + eprintf ("initialization for `%s' > %d\n", + pnamehold, len-1); + return (NULL); + } + + pp->p_val.v_s = memneed (btoi (len)); + if (pvaldefined (pp, initbuf)) + strcpy (pp->p_val.v_s, initbuf); + + } else { + /* Allocate space but don't init from next line. + */ + pp->p_val.v_s = memneed (btoi (len)); + } + + pp->p_val.v_s[len-1] = '\0'; /* the permanent eos */ + pp->p_lenval = len; + pp->p_valo.o_type = OT_STRING; + + } else if ((bastype == OT_STRING || + (s != NULL && *s == PF_INDIRECT)) && !arrflag) { + + /* Strings are stored like structs, but are inited from s. + * OT_INDEF/UNDEF refer to p_val. + */ + if (pvaldefined (pp, s)) { + /* String was something conventional. If shorter than SZ_LINE + * call memneed() again to increase the dictionary space. This + * ASSUMES that nothing called memneed() since nextfield() did. + */ + pp->p_valo.o_type = OT_STRING; + len = strlen (s) + 1; /* allow for eos */ + if (len < SZ_LINE) { + memneed (btoi(SZ_LINE) - btoi(len)); + len = SZ_LINE; + } + } else { + /* Either no string was given or it was INDEF/UNDEF. + */ + len = SZ_LINE; + s = memneed (btoi (len)); + } + + pp->p_val.v_s = s; + pp->p_val.v_s[len-1] = '\0'; /* add the permanent eos */ + pp->p_maxo.o_type = OT_INT; + pp->p_lenval = len; + + } else if (arrflag) { + /* For arrays get the array definition block */ + + int dim, it; /* Dimensionality of array. */ + short itemp; /* Length and offsets of array. */ + short *lenoff; /* Pointer to length or offset. */ + int d; + + /* Dimensionality. */ + if (s == NULL) { + eprintf ("Dimensionality not specified for %s.\n", pnamehold); + return (NULL); + } + if (ck_atoi (s, &dim) == ERR) { /* Convert to integer. */ + eprintf ("Non-integer dimensionality for %s.\n", pnamehold); + return (NULL); + } + if (dim <= 0) { /* Dimensionality > 0 ? */ + eprintf ("Dimensionality not positive for %d.\n", pnamehold); + return (NULL); + } + + /* Get space for array descriptor. */ + parrd = (struct arr_desc *) memneed (2 + dim); + size_arr = 1; + if (bastype == OT_REAL) /* Doubles take 2 INT's. */ + size_arr = 2; + + parrd->a_dim = dim; + lenoff = &(parrd->a_len); + + + /* Lengths and offsets. + */ + for (d=0; d < 2*dim; d++) { + if ((s = nextfield (tbuf, fp)) == NULL) { + eprintf ("Dimensions not specified for %s.\n", pnamehold); + return (NULL); + } + + if (ck_atoi (s, &it) == ERR) { /* Convert to integer. */ + eprintf ("Integer length/offset required for %s.\n", + pnamehold); + return (NULL); + } + + itemp = it; + if ((d%2 == 0) && itemp<=0) {/* Length < 0 ? */ + eprintf ("Illegal negative dimension for %s.\n", pnamehold); + return (NULL); + } + + *lenoff++ = itemp; + if (d%2 == 0) + size_arr = itemp * size_arr; + + } + /* Get the space for the array. */ + parrd->a_ptr.a_i = (int *) memneed(size_arr); + + /* The "value" of the parameter is a pointer to the + * array descriptor. + */ + pp->p_valo.o_val.v_a = parrd; + pp->p_valo.o_type = PT_ARRAY|bastype; + + } else { + /* Simple non-string type. + */ + if (pvaldefined (pp, s)) + pp->p_valo = makeop (s, pp->p_type & OT_BASIC); + } + + + /* P_MIN */ + + pp->p_mino.o_type = bastype; + + if ((s = nextfield (tbuf, fp)) == (char *)ERR) { + eprintf (umquotes, "minimum", pnamehold); + return (NULL); + } + + if (s != NULL && *s != '\0') { + if (bastype == OT_BOOL || + pp->p_type & (PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY|PT_PSET)) { + eprintf (nominmax, pnamehold); + return (NULL); + } else if (!strcmp(s,indefstr) || !strcmp(s,indeflc)) { + pp->p_flags |= P_IMIN; + } else if (bastype == OT_STRING || *s == PF_INDIRECT) { + /* Filename, enumerated string, or indirect reference. + */ + pp->p_mino.o_type = OT_STRING; + pp->p_min.v_s = memneed (btoi(PF_SZMINSTR)); + pp->p_min.v_s[PF_SZMINSTR-1] = '\0'; + strncpy (pp->p_min.v_s, s, PF_SZMINSTR-1); + } else { + /* Type is equivalent to a simple non-string wrt mins. + */ + pp->p_mino = makeop (s, pp->p_type & OT_BASIC); + } + } else + pp->p_flags |= P_UMIN; + + + /* P_MAX */ + + pp->p_maxo.o_type = bastype; + + if ((s = nextfield (tbuf, fp)) == (char *)ERR) { + eprintf (umquotes, "maximum", pnamehold); + return (NULL); + } + + if (s != NULL && *s != '\0') { + if (bastype == OT_BOOL || + pp->p_type & (PT_STRUCT|PT_GCUR|PT_IMCUR|PT_UKEY|PT_PSET)) { + eprintf (nominmax, pnamehold); + return (NULL); + } else if (!strcmp(s,indefstr) || !strcmp(s,indeflc)) { + pp->p_flags |= P_IMAX; + } else if (bastype == OT_STRING || *s == PF_INDIRECT) { + /* Filename, enumerated string, or indirect reference. + */ + pp->p_maxo.o_type = OT_STRING; + pp->p_max.v_s = memneed (btoi(PF_SZMAXSTR)); + pp->p_max.v_s[PF_SZMAXSTR-1] = '\0'; + strncpy (pp->p_max.v_s, s, PF_SZMAXSTR-1); + } else { + /* Type is equivalent to a simple non-string wrt mins. + */ + pp->p_maxo = makeop (s, pp->p_type & OT_BASIC); + } + } else + pp->p_flags |= P_UMAX; + + + /* P_PROMPT */ + + if ((s = nextfield (tbuf, fp)) == (char *)ERR) { + eprintf (umquotes, "prompt", pnamehold); + return (NULL); + } + + pp->p_prompt = (s == NULL) ? nullstr : s; + + + /* ARRAY INITIALIZATION */ + + if (arrflag) { + int i, len; + + /* First initialize all fields, since we do not + * require initialization of the entire array. + */ + if (bastype == OT_BOOL || bastype == OT_INT) { + int *p; + p = pp->p_aval.a_i; + for (i=0; i < size_arr; i++) + *p++ = INDEFL; + + } else if (bastype == OT_REAL) { + double *p; + size_arr = size_arr / 2; + p = pp->p_aval.a_r; + for (i=0; i < size_arr; i++) + *p++ = INDEFR; + + } else { /* Strings. */ + char **p; + + /* Check if max_length specified in p_max. + */ + if (pp->p_maxo.o_type == OT_INT) + len = pp->p_max.v_i; + else + len = SZ_FNAME; + pp->p_lenval = len; + + /* Set up indef strings. + */ + p = pp->p_aval.a_s; + for (i=0; i < size_arr; i++) { + *p = (char *) memneed (btoi (len) ); + strcpy(*p, INDEFSTR); + *(*p + len - 1) = '\0'; + p++; + } + } + + /* Now get any initialization which may be present. + * If we reach the end of the parameter before the + * array is filled it is not an error and the + * values are left with defaults. Values can be + * skipped with successive commas. + */ + for (i=0; ip_aval.a_i + i) = 1; + else + *(pp->p_aval.a_i + i) = 0; + } else if (bastype == OT_INT) { + *(pp->p_aval.a_i + i) = atoi(s); + } else if (bastype == OT_REAL) { + *(pp->p_aval.a_r + i) = atof(s); + } else { + char *dest; + dest = *(pp->p_aval.a_s + i) ; + strncpy (dest, s, len-1); + } + } + } + + /* Is there still more. + */ + if (nextfield (tbuf, fp) != NULL) { + eprintf ("too many fields for `%s'\n", pnamehold); + return (NULL); + } + + /* Got through whole line without errors. + */ + return (pp); +} + + +/* CK_ATOI -- Check a string for non-numerics before conversion. + */ +int +ck_atoi ( + char *str, + int *val +) +{ + char *s; + + s = str; + while (*s == ' ' || *s == '\t') + s++; + + if (*s == '-') + s++; + + while (*s) + if (!isdigit(*s++)) + return (ERR); + + *val = atoi(str); + return (0); +} + + +/* NEXTFIELD -- Compile the next field of a paramfile line into the dictionary + * and return a pointer to the new entry. + * PP is the address of a pointer to the start of a param field. skip leading + * blanks and handle quoted strings. strings ending in \ are continued after + * absorbing both the \ and the newline. strings ending with just newlines + * will contain the newline. the string may be delimited by ' or ". + * The callers pointer, *pp, will be set to the beginning of the next field. + * FP is a file pointer, needed if the field is quoted and extends to another + * lines. + * The field must be part of a line read with fgets (buf, SZ_LINE, fp); we + * rely on the max length as well as the trailing \n\0 sequence. + * Return NULL if no further fields, ERR if don't find closing quote, + * else pointer to field as compiled in dictionary. If the field was + * empty return a pointer to the string "undefval". + */ +char * +nextfield ( + char **pp, + FILE *fp +) +{ + static char readbuf[SZ_LINE]; + register char c, *p; /* fast references to field */ + char buf[SZ_LINE]; /* working scratch buffer */ + char *bp = buf; /* pointer into scratch buffer */ + char *start = NULL; /* start of compiled string in dictnry */ + char quote; /* set to opening quote; go until match */ + + p = *pp; + if (p == NULL) + return (NULL); + + /* Skip white space at beginning. This may include one or + * more newlines if they are prefixed by a '\\'. + */ + forever { + while (*p == ' ' || *p == '\t') + p++; + if (*p == '\\' && *(p+1) == '\n') { + if (fgets (readbuf, SZ_LINE, fp) == NULL) + return ((char *) ERR); + p = readbuf; + continue; + } else + break; + } + + c = *p; + + if (c == '\0' || c == '\n') { + *pp = NULL; + return (NULL); + } + + if (c == '\'' || c == '"') { + quote = c; + p++; + + forever { + c = *p++; + if (c == '\n') { + *bp++ = c; + continue; + } else if (c == '\\') { + switch (c = *p++) { + case '\n': + continue; + case 'n': + *bp++ = '\n'; + break; + case 't': + *bp++ = '\t'; + break; + case 'r': + *bp++ = '\r'; + break; + case 'f': + *bp++ = '\f'; + break; + case '\'': + case '"': + *bp++ = c; + break; + default: + *bp++ = '\\'; /* preserve esc seq. */ + *bp++ = c; + break; + } + } else if (c == '\0' || c == quote) { + *bp = '\0'; + if (start == NULL) + start = comdstr (buf); + else + catdstr (start, buf); + + if (c == quote) + break; + else { + if (fgets (readbuf, SZ_LINE, fp) == NULL) + return ((char *)ERR); + p = readbuf; + bp = buf; + } + } else + *bp++ = c; + } + *bp++ = '\0'; + + /* Skip any white space. We assume that we needn't skip + * lines here. + */ + while (*p == ' ' || *p == '\t') + *p++; + + c = *p; + + } else { + /* Unquoted string. + * Changed 2/15/85 by TAM. + * This code is no longer seen by quoted strings + */ + while (*p != '\0' && *p != '\n' && *p != ',' && *p != '#') { + c = *p; + + /* Allow multi-line definitions by ignoring newlines + * prefixed by backslash. + */ + if (c == '\\' && *(p+1) == '\n') { + if (fgets (readbuf, SZ_LINE, fp) == NULL) + return ((char *)ERR); + p = readbuf; + continue; + } else + *bp++ = c; + + p++; + } + } + + /* Get rid of comments after the field. */ + if (*p == '#') + while (*p != '\0') + p++; + + c = *p; + + /* At this point we must be at a field terminator, i.e. + * comma, newline or null. + */ + if (c != ',' && c != '\n' && c != '\0') + return ((char *)ERR); + + + /* if stopped due to \n or , skip over it. + * set caller's pointer to start of next field. + * if we've not already compiled a string, compile this field. + */ + if (c == '\n' || c == ',') + p++; + + if (start == NULL) { + if (bp == buf) { + /* The field was empty (i.e., ",,"). Return point to the + * null string "undefval" to flag value as undefined. + */ + start = undefval; + } else { + *bp = '\0'; + start = comdstr (buf); + } + *pp = p; + } else if (*pp != NULL) + *pp = p; + + return (start); +} + + +/* MAKELOWER -- Convert, in-place, any upper case characters in the string + * cp to lower. Using isupper and tolower is fast and portable, but making + * simple range test and subtraction will save the table space if you know + * you have ASCII. + */ +char * +makelower ( + register char *cp +) +{ + char *start = cp; + register char c; + + while ((c = *cp) != '\0') { + if ('A' <= c && c <= 'Z') + *cp = c + ('a' - 'A'); + cp++; + } + + return (start); +} + + +/* SCANMODE -- Read through string s and build up an int full of M_XXX type + * mode bits. Return it if ok, else ERR. + * We write a diagnostic with eprint() if ERR but not a '\n' so + * caller can include more info if necessary. + * N.B. we assume ERR doesn't map into a reasonable set of flags. + */ +int +scanmode (char *s) +{ + register int mode = 0; + register char *str, *ip, *op; + static char *badstr = "bad mode string `%s'"; + char strings[4][25]; + int i, n; + char *index(); + + str = s; + if (index (str, ',') != NULL || index (str, '+') != NULL) { + if (*str == '"' || *str == '\'') + str++; + + /* Break str into alpha strings separated by '+', ' ', or ','. + * We will not see any more than 4 such strings. + */ + for (n=0, ip=str; n < 4; n++) { + while (*ip == ' ' || *ip == '\t') + ip++; + for (op=strings[n]; (*op = *ip++) != '\0'; op++) + if (!isalpha (*op)) { + *op = '\0'; + break; + } + } + if (n == 0 || n == 5) { + eprintf (badstr, str); + return (ERR); + } + + for (i=0; i < n; i++) { + str = strings[i]; + makelower (str); + if (!strcmp (str, "auto") || !strcmp (str, "a")) + mode |= M_AUTO; + else if (!strcmp (str, "hidden") || !strcmp (str, "h")) + mode |= M_HIDDEN; + else if (!strcmp (str, "learn") || !strcmp (str, "l")) + mode |= M_LEARN; + else if (!strcmp (str, "query") || !strcmp (str, "q")) + mode |= M_QUERY; + else if (!strcmp (str, "menu") || !strcmp (str, "m")) + mode |= M_MENU; + else { + eprintf (badstr, str); + return (ERR); + } + } + + } else { + for (ip=str; *ip != '\0'; ip++) { + /* Handle the case of a set of qlha run together, as in + * a parameter file spec. + */ + switch (*ip) { + case PF_AUTO: case PF_AUTO - ('a' - 'A'): + mode |= M_AUTO; + break; + case PF_HIDDEN: case PF_HIDDEN - ('a' - 'A'): + mode |= M_HIDDEN; + break; + case PF_LEARN: case PF_LEARN - ('a' - 'A'): + mode |= M_LEARN; + break; + case PF_QUERY: case PF_QUERY - ('a' - 'A'): + mode |= M_QUERY; + break; + case PF_MENU: case PF_MENU - ('a' - 'A'): + mode |= M_MENU; + break; + default: + eprintf ("Bad mode spec `%c' in `%s'\n", *ip, str); + return (ERR); + } + } + } + + return (mode); +} + + +/* SCANTYPE -- Read through string s and build up an int full of OT_XXX and + * PT_XXX type bits. Return it if ok, else ERR. + * OT_ bits are not unique so be a bit carefile. + * we write a diagnostic with eprint() if ERR but not a '\n' so + * caller can include more info if necessary. + * N.B. hope ERR doesn't map into a reasonable set of flags. + */ +int +scantype ( + register char *s +) +{ + static char *badtype = "bad type spec `%c'"; + static char *cnfltype = "conflicting type spec `%c'"; + register int type; + + type = 0; + + if (*s == '*') { + type |= PT_LIST; + s++; + } + + if (*s == 'a' || *s == 'A') { + if (type & PT_LIST) { /* No list structured arrays. */ + eprintf (cnfltype, *s); + return (ERR); + } + s++; + type |= PT_ARRAY; + } + + if (s[1] == '\0') { + switch (*s) { + case 'b': case 'B': type |= OT_BOOL; break; + case 'i': case 'I': type |= OT_INT; break; + case 'r': case 'R': type |= OT_REAL; break; + case 's': case 'S': type |= OT_STRING; break; + case 'f': case 'F': type |= (PT_FILNAM|OT_STRING); break; + default: eprintf (badtype, *s); + return (ERR); + } + + } else if (*s == 'f') { + type |= (PT_FILNAM + OT_STRING); + while (*++s != '\0') + switch (*s) { + case 'b': case 'B': type |= PT_FBIN; break; + case 'n': case 'N': type |= PT_FNOE; break; + case 'r': case 'R': type |= PT_FER; break; + case 't': case 'T': type |= PT_FTXT; break; + case 'w': case 'W': type |= PT_FEW; break; + default: eprintf (badtype, *s); + return (ERR); + } + } else if (!strcmp (makelower (s), "struct")) { + type |= (PT_STRUCT|OT_STRING); + } else if (!strcmp (makelower (s), "gcur")) { + type |= (PT_GCUR|OT_STRING); + } else if (!strcmp (makelower (s), "imcur")) { + type |= (PT_IMCUR|OT_STRING); + } else if (!strcmp (makelower (s), "ukey")) { + type |= (PT_UKEY|OT_STRING); + } else if (!strcmp (makelower (s), "pset")) { + type |= (PT_PSET|OT_STRING); + } else { + eprintf (badtype, *s); + return (ERR); + } + + return (type); +} diff --git a/pkg/cl/prcache.c b/pkg/cl/prcache.c new file mode 100644 index 00000000..b222c042 --- /dev/null +++ b/pkg/cl/prcache.c @@ -0,0 +1,724 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#define import_error +#define import_finfo +#define import_prstat +#include + +#include "config.h" +#include "errs.h" +#include "task.h" +#include "operand.h" +#include "param.h" +#include "proto.h" + + +/* + * PRCACHE -- To minimize spawns, we maintain a cache of processes. Each + * process may contain any number of tasks. Zero or one tasks may be active + * in a process at a given time. A process is spawned and added to the + * cache when a task therein needs to be run. A process is terminated when + * its cache slot is needed by another process or when the cache is flushed. + * Error recovery does not normally result in process termination, even when + * the error is initiated by a task resident in the process. + * + * pid = pr_connect (process, command, &in,&out, tin,tout,terr, timeit) + * pr_disconnect (pid) + * pr_lock (pid) + * pr_unlock (pid) + * pr_dumpcache (pid, break_locks) + * pr_chdir (pid, newdir) + * pr_envset (pid, envvar, valuestr) + * pid = pr_cachetask (ltname) + * pid = pr_pnametopid (pname) + * pr_listcache (fp) + * pr_setcache (sz_prcache) + * pno = pr_getpno () + * pr_prunecache (pno) + * + * The PR_CONNECT procedure executes an ltask resident in an external compiled + * process. A process spawn occurs only if the process is not found in + * the cache or is not idle. PR_DISCONNECT should be called when the ltask + * terminates to signal that the process is idle. Processes may be locked + * in the cache, but this facility must be used with great discretion as + * it defeats the purpose of the cache and may lead to lockout. + * + * A process is passed the environment list and the name of the current working + * directory when it is spawned. New SET environment declarations or chdir + * directives may be passed to all processes in the cache without flushing + * and refilling the cache, using the PR_CHDIR and PR_ENVSET commands. + * Pseudofile i/o (xmit and xfer) is handled automatically by the system. + * Our function here is to connect the pseudofile streams of the ltask + * up to real streams at connect() time, via calls to c_prredir(). + * + * The size of the cache is a runtime time parameter controlled by the CL + * parameter `szprcache'. The default value of this is set either in + * cl$cl.par or in hlib$clpackage.par, hence may vary from site to site + * or even from host to host. + */ + +extern int cldebug; +extern int cltrace; + +typedef XINT (*PFI)(); + +struct process { + int pr_pid; /* process id of subprocess */ + long pr_time; /* time when process executed */ + short pr_flags; /* flag bits */ + short pr_pno; /* prcache process number */ + FILE *pr_in, *pr_out; /* in, out IPC channels */ + struct process *pr_up; /* up link (toward head) */ + struct process *pr_dn; /* down link (toward tail) */ + char pr_name[SZ_PATHNAME+1]; /* filename of process */ +}; + +#define P_ACTIVE 01 /* task in process is in use */ +#define P_LOCKED 02 /* process is locked in cache */ + +#define pr_idle(pr) (((pr)->pr_flags&P_ACTIVE)==0) +#define pr_busy(pr) (((pr)->pr_flags&(P_ACTIVE|P_LOCKED))!=0) + +int pr_pno = 1; /* incremented for each connect */ +int sz_prcache = 2; /* nprocess slots in cache */ +struct process pr_cache[MAXSUBPROC]; +struct process *pr_head = NULL, *pr_tail = NULL; +extern char *findexe(); +extern int c_finfo(); + + +static void pr_pdisconnect (register struct process *pr); +static void pr_tohead (register struct process *pr); +static void pr_totail (register struct process *pr); +static void pr_unlink (register struct process *pr); + + +/* PR_CONNECT -- Run a task resident in an external process. Look in the cache + * for the named process; if not found or already active, spawn the process + * and add it to the cache. Send the startup message to the child to start + * the task in execution. The startup message specifies the name of the task + * to be run, whether timing is desired, and any i/o redirection desired. + * The input and output IPC file pointers are returned to the caller. + * + * TODO: This procedure was designed to minimize the changes to the high level + * code, and is not done right. Formatting of the startup command should be + * done in a procedure within this package, rather than at the high level, + * and should support i/o redirection to named files for (greatly) increased + * efficiency of pipes. + */ +int +pr_connect ( + char *process, /* filename of process */ + char *command, /* IRAF Main command */ + FILE **in, /* IPC channels (output) */ + FILE **out, + FILE *t_in, /* task stdin,out,err (input) */ + FILE *t_out, + FILE *t_err, + FILE *t_gr, /* task graphics streams */ + FILE *t_im, + FILE *t_pl, + int timeit /* if !0, time command */ +) +{ + register int pid; + + /* Connect subprocess. */ + if ((pid = pr_pconnect (process, in, out)) == NULL) + c_erract (EA_ERROR); + + + /* Set default redirection of the standard i/o streams. + */ + c_prredir (pid, STDIN, fileno(t_in)); + c_prredir (pid, STDOUT, fileno(t_out)); + c_prredir (pid, STDERR, fileno(t_err)); + c_prredir (pid, STDGRAPH, fileno(t_gr)); + c_prredir (pid, STDIMAGE, fileno(t_im)); + c_prredir (pid, STDPLOT, fileno(t_pl)); + + /* Send startup message. */ + if (timeit) + fputc ('$', *out); + fputs (command, *out); + fflush (*out); + + if (cldebug) + eprintf ("connect: *in, *out, t_in, t_out: %d %d %d %d\n", + *in, *out, t_in, t_out); + if (cltrace) { + d_fmtmsg (stderr, "\t ", command, 80 - 13); + eprintf ("\t--------------------------------\n"); + } + + return (pid); +} + + +/* PR_DISCONNECT -- Called when a task resident in an external process + * terminates; also called during error recovery, e.g., following X_IPC. + * Our only function for normal task termination is to clear the active flag. + * Until the active flag is cleared the process cannot be reused nor terminated. + */ +void +pr_disconnect ( + int pid /* process id returned by connect */ +) +{ + register struct process *pr; + + pr_checkup(); + for (pr=pr_head; pr != NULL; pr = pr->pr_dn) { + if (pr->pr_pid == pid) { + pr->pr_flags &= ~P_ACTIVE; + return; + } + } +} + + +/* PR_PCONNECT -- Run a task resident in an external process. Look in the cache + * for the named process; if not found or already active, spawn the process + * and add it to the cache. Return the process id and file pointers to the + * IPC channels to the caller. + */ +int +pr_pconnect ( + char *process, /* filename of process */ + FILE **in, + FILE **out /* IPC channels (output) */ +) +{ + register struct process *pr; + struct process *pr_findproc(); + struct _finfo fi; + int fd_in, fd_out; + + if (pr_head == NULL) + pr_initcache(); + else + pr_checkup(); + + /* Search the cache to see if the process is already connected and + * inactive. If the process is found idling in the cache, relink it + * at the head of the cache list, otherwise disconnect the inactive + * process nearest the tail of the list and spawn the new one to + * replace it. The cached entry is automatically invalidated if the + * corresponding executable file has been modified (e.g., relinked), + * provided the process is not currently busy. A process is considered + * busy if it is active or if it is locked in the cache. + */ + fi.fi_mtime = 0; + if ((pr = pr_findproc (process)) != NULL && !pr_busy(pr)) { + if (c_finfo (process, &fi) == ERR || fi.fi_mtime > pr->pr_time) { + pr_pdisconnect (pr); + pr = NULL; + } + } + + if (pr != NULL) + pr_tohead (pr); + else { + /* Get process slot. */ + for (pr=pr_tail; pr != NULL; pr=pr->pr_up) + if (!pr_busy(pr)) { + if (pr->pr_pid != NULL) + pr_pdisconnect (pr); + break; + } + if (pr == NULL) + cl_error (E_UERR, "process cache deadlock"); + pr_tohead (pr); + + /* Spawn subprocess. Turn off interrupts during process startup + * to avoid crashing the IPC protocol. + */ + if (cltrace) + eprintf ("\t----- connect to %s -----\n", process); + intr_disable(); + if ((pr->pr_pid = c_propen (process, &fd_in, &fd_out)) == NULL) { + intr_enable(); + return (NULL); + } + intr_enable(); + + if (fi.fi_mtime == 0) + if (c_finfo (process, &fi) == ERR) + fi.fi_mtime = 0; + + pr->pr_time = fi.fi_mtime; + pr->pr_in = FDTOFP (fd_in); + pr->pr_out = FDTOFP (fd_out); + pr->pr_flags = 0; + pr->pr_pno = pr_getpno(); + strcpy (pr->pr_name, process); + } + + pr->pr_flags |= P_ACTIVE; + *in = pr->pr_in; + *out = pr->pr_out; + + return (pr->pr_pid); +} + + +/* PR_PDISCONNECT -- Remove a process from the process cache. Processes are + * disconnected when pushed out of the cache or when the cache is flushed. + */ +static void +pr_pdisconnect ( + register struct process *pr +) +{ + /* Ignore attempts to dump active processes. This might happen + * when an active process executes a command which calls dumpcache. + */ + if (pr == NULL || pr->pr_pid == NULL || pr_busy(pr)) + return; + + if (cltrace) + eprintf ("\t----- disconnect %s -----\n", pr->pr_name); + + /* Command child process to exit, close down communications. This + * closes the IPC files as well as the terminating the process. + */ + c_prclose (pr->pr_pid); + + /* Clear process table entry and move process to tail of list. + */ + pr->pr_pid = 0; + pr_totail (pr); +} + + +/* PR_SETCACHE -- Set the size of the process cache. This is automatically + * called whenever the value of the parameter cl.szprcache is set. Changing + * the cache size on an active cache causes the cache to be flushed and all + * locked processes to be reconnected. + */ +void +pr_setcache (int new_szprcache) +{ + register struct process *pr; + char pname[MAXSUBPROC][SZ_PATHNAME+1]; + int nprocs=0, pid, i; + FILE *fdummy; + + if (pr_head == NULL) + pr_initcache(); + else { + /* Get the names of any processes currently locked into the cache, + * then dump the cache. + */ + for (pr=pr_head; pr != NULL; pr=pr->pr_dn) + if (pr->pr_pid != NULL && (pr->pr_flags & P_LOCKED)) + strcpy (pname[nprocs++], pr->pr_name); + pr_dumpcache (0, 1); + } + + /* Set the new value of sz_prcache. */ + sz_prcache = new_szprcache; + if (sz_prcache < 2) + sz_prcache = 2; + else if (sz_prcache > MAXSUBPROC) + sz_prcache = MAXSUBPROC; + + /* Relink the empty cache for sz_prcache cache slots. */ + pr_initcache(); + + /* Attempt to recache the formerly locked processes. There must be + * at least one empty slot left for new subprocesses. + */ + if (nprocs+1 > sz_prcache) + nprocs = sz_prcache-1; + + for (i=0; i < nprocs; i++) { + pid = pr_connect (findexe(NULL,pname[i]), "\n", &fdummy, &fdummy, + stdin, stdout, stderr, 0,0,0, 0); + pr_disconnect (pid); + pr_lock (pid); + } +} + + +/* PR_FINDPROC -- Search the cache for the named process. Skip active + * processes. + */ +struct process * +pr_findproc (char *process) +{ + register struct process *pr; + + for (pr=pr_head; pr != NULL; pr=pr->pr_dn) { + if (pr->pr_pid != NULL && pr_idle(pr)) + if (strcmp (process, pr->pr_name) == 0) + return (pr); + } + + return (NULL); +} + + +/* PR_CACHETASK -- Cache the process containing the named logical task. + * If the process is already connected merely returns its pid, else connect + * the process and return its pid. + */ +int +pr_cachetask ( + char *ltname /* logical task name */ +) +{ + register int pid; + struct ltask *ltp; + FILE *fdummy; + + ltp = ltasksrch ("", ltname); + if (ltp->lt_flags & (LT_SCRIPT|LT_BUILTIN)) + return (ERR); + if ((pid = pr_pnametopid(findexe(ltp->lt_pkp,ltp->lt_pname))) == NULL) { + pid = pr_connect (findexe(ltp->lt_pkp,ltp->lt_pname), "\n", &fdummy, + &fdummy, stdin, stdout, stderr, 0,0,0, 0); + pr_disconnect (pid); + } + + return (pid); +} + + +/* PR_LOCK -- Lock a connect process in the cache. Must be used with caution + * as deadlock may occur. Locked processes are also not disconnected by + * pr_dumpcache, which may not be what is desired. + */ +void +pr_lock ( + register int pid /* process id */ +) +{ + register struct process *pr; + + if (pid != NULL) { + for (pr=pr_head; pr != NULL; pr=pr->pr_dn) + if (pr->pr_pid == pid) { + pr->pr_flags |= P_LOCKED; + break; + } + } +} + + +/* PR_UNLOCK -- Unlock a process, allowing it to be disconnected either when + * forced out of the cache by another disconnect, or by a dumpcache. + * + * This function is currently unused. + */ +int +pr_unlock ( + register int pid /* process id */ +) +{ + register struct process *pr; + + if (pid != NULL) + for (pr=pr_head; pr != NULL; pr=pr->pr_dn) + if (pr->pr_pid == pid) + return (pr->pr_flags &= ~P_LOCKED); + + return (ERR); +} + + +/* PR_LISTCACHE -- Info command, used to display the contents of the process + * cache. Format: pid [RH][L] process_name + */ +void +pr_listcache ( + FILE *fp /* output file */ +) +{ + register struct process *pr; + + pr_checkup(); + for (pr=pr_head; pr != NULL; pr=pr->pr_dn) + if (pr->pr_pid) { + int os_pid; + char nodename[SZ_FNAME+1]; + char out[100]; + + /* Print out pid in both decimal and hex, since the host + * system might need either. Also print the VOS pid since + * that is what is needed for flprcache (although flprcache + * will accept a task name instead). Note that c_kimapchan + * must be called to get the host PID if networking is in use. + */ + os_pid = c_kimapchan (pr->pr_pid, nodename, SZ_FNAME); + sprintf (out, "[%02d] %s!%d(%xX)", + pr->pr_pid, nodename, os_pid, os_pid); + fprintf (fp, " %-32s %c%c %s\n", + out, + (pr->pr_flags&P_ACTIVE) ? 'R' : 'H', + (pr->pr_flags&P_LOCKED) ? 'L' : ' ', + pr->pr_name); + + } else { + fprintf(fp, "%12d", 0); + fputc ('\n',fp); + } +} + + +/* PR_DUMPCACHE -- Disconnect the named process, or disconnect all processes + * currently running in the cache, and clear the process tables. A count of + * the number of active processes not disconnected is returned as the function + * value. Locks may be forced if desired, i.e., when dumping the cache prior + * to process termination. + */ +void +pr_dumpcache ( + int pid, + int break_locks +) +{ + register struct process *pr; + register int n; + + + pr_checkup(); + + /* Do not traverse list using list pointers, because the first + * pr_disconnect will leave process pr at the tail of the list, + * causing premature termination. + */ + for (pr=pr_cache, n=sz_prcache; --n >= 0; pr++) + if ((pid == 0 && pr->pr_pid) || (pid == pr->pr_pid)) { + if (break_locks && pr_idle(pr)) + pr->pr_flags &= ~P_LOCKED; + pr_pdisconnect (pr); + } + + if (break_locks) + pr_pno = 1; +} + + +/* PR_PRUNECACHE -- Disconnect all processes currently running in the cache + * for which the process number is greater than that given, i.e., which were + * connected since the given PNO was assigned. Locked processes are not + * affected. + */ +void +pr_prunecache (int pno) +{ + register struct process *pr; + register int n; + + pr_checkup(); + + /* Do not traverse list using list pointers, because the first + * pr_disconnect will leave process pr at the tail of the list, + * causing premature termination. + */ + for (pr=pr_cache, n=sz_prcache; --n >= 0; pr++) + if (pr->pr_pid && pr->pr_pno > pno) + pr_pdisconnect (pr); +} + + +/* PR_GETPNO -- Get the next process number. These are supposed to be returned + * in time order. If 10 million processes are spawned without setcache being + * called, the counter might wrap around, but that does not seem likely and is + * harmless in any case. + */ +int +pr_getpno (void) +{ + return (pr_pno++); +} + + +/* PR_PNAMETOPID -- Lookup the named process in the cache and return the pid + * if found, NULL otherwise. + */ +int +pr_pnametopid (char *pname) +{ + register struct process *pr; + + pr_checkup(); + for (pr=pr_head; pr != NULL; pr=pr->pr_dn) + if (strcmp (pr->pr_name, pname) == 0) + return (pr->pr_pid); + + return ((int) NULL); +} + + +/* PR_CHDIR -- Change the current working directory of a child process, or + * of all connected but idle processes if pid=0. + */ +void +pr_chdir ( + register int pid, + char *newdir +) +{ + register struct process *pr; + + pr_checkup(); + for (pr=pr_head; pr != NULL; pr=pr->pr_dn) + if (pr->pr_pid == NULL || !pr_idle(pr)) + continue; + else if (pid == NULL || pr->pr_pid == pid) + c_prchdir (pr->pr_pid, newdir); +} + + +/* PR_ENVSET -- Set the value of an environment variable in a child process, + * or in all connected but idle processes if pid=0. + */ +void +pr_envset ( + register int pid, + char *envvar, + char *valuestr +) +{ + register struct process *pr; + + pr_checkup(); + for (pr=pr_head; pr != NULL; pr=pr->pr_dn) + if (pr->pr_pid == NULL || !pr_idle(pr)) + continue; + else if (pid == NULL || pr->pr_pid == pid) + c_prenvset (pr->pr_pid, envvar, valuestr); +} + + +/* PR_CHECKUP -- Check on the status of all connected child processes to see + * if any have died. If a process has died we must disconnect the process + * to free file descriptors and the process cache slot. + */ +void +pr_checkup (void) +{ + register struct process *pr; + register int n; + + /* Do not traverse list using list pointers, because the first + * pr_disconnect will leave process pr at the tail of the list, + * causing premature termination. + */ + for (pr=pr_cache, n=sz_prcache; --n >= 0; pr++) + if (pr->pr_pid != NULL) + if (c_prstati (pr->pr_pid, PR_STATUS) == P_DEAD) { + pr->pr_flags = 0; + pr_pdisconnect (pr); + } +} + + +/* ONIPC -- Call this when get a signal that indicates a write to an IPC + * channel with no reader. We are called after the system X_IPC handler + * has been called to cleanup the internal process tables and file system, + * disabling any further output to the process. + */ +/* ARGSUSED */ +void +onipc ( + int *vex, /* virtual exception code */ + PFI *next_handler /* next handler to be called */ +) +{ + register struct process *pr; + + for (pr=pr_head; pr != NULL; pr=pr->pr_dn) + if (pr->pr_pid != NULL) + if (c_prstati (pr->pr_pid, PR_STATUS) == P_DEAD) + break; + + cl_error (E_UERR, "Abnormal termination of child process '%s'", + pr ? pr->pr_name : "??"); +} + + +/* PR_INITCACHE -- Initialize the process cache, i.e., set up the queue for the + * first time. The minimum cache size is 2. + */ +void +pr_initcache (void) +{ + register struct process *pr; + register int n; + + for (pr=pr_cache, n=MAXSUBPROC; --n >= 0; pr++) { + pr->pr_pid = 0; + pr->pr_flags = 0; + pr->pr_pno = 0; + pr->pr_in = pr->pr_out = NULL; + pr->pr_up = pr->pr_dn = NULL; + } + + pr_head = pr_tail = pr_cache; + for (n=1; n < sz_prcache; n++) + pr_tohead (&pr_cache[n]); + + pr_pno = 1; +} + + +/* PR_TOHEAD -- Relink a process at the head of the cache list. + */ +void +pr_tohead ( + register struct process *pr +) +{ + if (pr_head != pr) { + pr_unlink (pr); + pr->pr_dn = pr_head; + pr->pr_up = NULL; + pr_head->pr_up = pr; + pr_head = pr; + } +} + + +/* PR_TOTAIL -- Relink a process at the tail of the cache list. + */ +static void +pr_totail ( + register struct process *pr +) +{ + if (pr_tail != pr) { + pr_unlink (pr); + pr->pr_up = pr_tail; + pr->pr_dn = NULL; + pr_tail->pr_dn = pr; + pr_tail = pr; + } +} + + +/* PR_UNLINK -- Unlink a process from the list. + */ +static void +pr_unlink ( + register struct process *pr +) +{ + if (pr->pr_up) { + (pr->pr_up)->pr_dn = pr->pr_dn; + if (pr == pr_tail) + pr_tail = pr->pr_up; + } + + if (pr->pr_dn) { + (pr->pr_dn)->pr_up = pr->pr_up; + if (pr == pr_head) + pr_head = pr->pr_dn; + } +} diff --git a/pkg/cl/proto.h b/pkg/cl/proto.h new file mode 100644 index 00000000..33ac4a8c --- /dev/null +++ b/pkg/cl/proto.h @@ -0,0 +1,447 @@ +/* binop.c */ +extern char *strint(register char *s, int side); +extern void binop(int opcode); +extern void binexp(int opcode); +/* bkg.c */ +extern void bkg_init(char *bcs); +extern void bkg_spawn(char *cmd); +extern void bkg_wait(register int job); +extern void bkg_kill(int job); +extern void bkg_jobstatus(struct _iobuf *fp, int job); +extern int bkg_jobactive(int job); +extern void bkg_update(int pmsg); +extern int bkg_wfservice(int job); +extern void bkg_delfiles(int job); +extern void bkg_startup(char *bkgfile); +extern void bkg_abort(void); +extern char *wbkgfile(int jobno, char *cmd); +extern void rbkgfile(char *bkgfile); +/* builtin.c */ +extern void clbye(void); +extern void cllogout(void); +extern void clclbye(void); +extern void clcache(void); +extern void cl_locate(char *task_spec, int first_only); +extern void clwhich(void); +extern void clwhereis(void); +extern void clflprcache(void); +extern void flpr_task(char *task); +extern void clprcache(void); +extern void clgflush(void); +extern void clchdir(void); +extern void clback(void); +extern void clerror(void); +extern void clhelp(void); +extern void clallhelp(void); +extern void clhistory(void); +extern void dotrace(void); +extern void clehistory(void); +extern void clservice(void); +extern void clkeep(void); +extern void clkill(void); +extern void cleparam(void); +extern void cllparam(void); +extern void cldparam(void); +extern void clpack(void); +extern void clcurpack(void); +extern void clpkg(void); +extern void lapkg(void); +extern void clprint(void); +extern void clfprint(void); +extern void do_clprint(char *dest); +extern void clprintf(void); +extern void clscans(void); +extern void clscanf(void); +extern void clputlog(void); +extern void clset(void); +extern void clreset(void); +extern void clshow(void); +extern void clstty(void); +extern void cltask(int redef); +extern void clrtask(void); +extern void clntask(void); +extern void clforeign(void); +extern void clunlearn(void); +extern void clupdate(void); +extern void clhidetask(void); +extern void clwait(void); +extern void cljobs(void); +extern void clfunc(void); +extern void clbeep(void); +extern void cltime(void); +extern void clclear(void); +extern void clsleep(void); +extern void cledit(void); +extern void clallocate(void); +extern void cldeallocate(void); +extern void cldevstatus(void); +extern void clerrpsh(void); +extern void clerreset(void); +extern void clonerror(void); +extern void setbuiltins(register struct package *pkp); +extern void newbuiltin(struct package *pkp, char *lname, void (*fp)(void), int flags, char *ftprefix, int redef); +extern int mkarglist(register struct pfile *pfp, char *args, char *argp[]); +extern void pushfparams(register struct param *pp); +extern void pushbparams(struct param *pp); +extern void pushbpvals(struct param *pp); +extern int nargs(struct pfile *pfp); +extern void keep(register struct task *tp); +/* clprintf.c */ +extern void u_eprintf(char *fmt, ...); +extern void oprintf(char *fmt, ...); +extern void tprintf(char *fmt, ...); +extern void prparamval(struct param *pp, struct _iobuf *fp); +extern void strsort(char *list[], int nstr); +extern int qstrcmp(char *a, char *b); +extern void strtable(struct _iobuf *fp, char *list[], int nstr, int first_col, int last_col, int maxch, int ncol); +/* clsystem.c */ +extern void clsystem(char *cmd, struct _iobuf *taskout, struct _iobuf *taskerr); +/* compile.c */ +extern int compile(int opcode, ...); +extern int comstr(register char *s, memel *loc); +extern char *comdstr(char *s); +extern void catdstr(char *es, char *ns); +/* debug.c */ +extern void d_asmark(void); +extern void d_assemble(void); +extern void d_stack(register XINT locpc, int ss); +extern int d_instr(struct _iobuf *fp, char *prefix, register XINT locpc); +extern void d_d(void); +extern void d_p(void); +extern void d_t(void); +extern void d_l(void); +extern void d_f(void); +extern void d_on(void); +extern void d_off(void); +extern void d_trace(int value); +extern void e_dumpop(void); +extern void d_fmtmsg(struct _iobuf *fp, char *prefix, char *message, int width); +extern void d_prof(void); +/* decl.c */ +extern int getlimits(char *pname, int n, int *i1, int *i2); +extern int get_dim(char *pname); +extern int maketype(int type, int list); +extern void do_arrayinit(struct param *pp, int nval, int nindex); +extern void do_scalarinit(struct param *pp, int inited); +extern int scanftype(struct param *pp, struct operand *o); +extern int c_scanmode(struct param *pp, struct operand *o); +extern int scanlen(struct param *pp, struct operand *o); +extern int scanmin(struct param *pp, struct operand *o); +extern int scanenum(register struct param *pp, register struct operand *o); +extern int scanmax(struct param *pp, struct operand *o); +extern void proc_params(int npar); +extern struct param *initparam(struct operand *op, int isparam, int type, int list); +extern int procscript(struct _iobuf *fp); +extern int skip_to(struct _iobuf *fp, char *key); +extern void do_option(struct param *pp, struct operand *oo, struct operand *o); +/* edcap.c */ +extern void edtinit(void); +extern void edtexit(void); +extern char *host_editor(char *editor); +extern void get_editor(char *editor); +extern int what_cmd(char first_char); +extern int cmd_match(char *cstring, int nchars); +extern void show_editorhelp(void); +/* eparam.c */ +extern int epset(char *pset); +extern int e_makelist(struct pfile *pfileptr); +extern int e_testtop(int cur, int new); +extern void e_repaint(void); +extern void e_pheader(struct pfile *pfp, int cmdline, int maxcol); +extern void e_drawkey(void); +extern void e_encode_vstring(struct param *pp, char *outbuf); +extern void e_check_vals(char *string); +extern int e_undef(register char *s); +extern void e_rpterror(char *errstr); +extern void e_clrerror(void); +extern char *e_getfield(register char *ip, char *outstr, int maxch); +extern int e_psetok(char *pset); +extern void e_puterr(char *errmsg); +extern void e_ttyexit(void); +extern int e_moreflag(int topkey); +extern void e_ttyinit (void); +extern int e_scrollit(void); +extern int e_colon (void); +extern int editstring (char *string, int eparam); +extern int e_moveup(int eparam); +extern int e_movedown(int eparam); +extern char *e_tonextword(register char *ip); +extern char *e_toprevword(char *ip, char *string); +extern void e_ctrl(char *cap); +extern void e_goto(int col, int line); +extern void e_putline(char *stwing); +extern void e_clear(void); +extern void e_clrline(void); +extern void e_display(char *string, int sline, int scol); +extern void e_displayml(char *string, int sline, int scol, int ccol); +/* errs.c */ +extern void cl_error(int errtype, char *diagstr, ...); +extern void erract_init(void); +/* exec.c */ +extern void run(void); +extern void callnewtask(char *name); +extern void execnewtask(void); +extern void mk_startupmsg(struct task *tp, char *cmd, int maxch); +extern char *findexe(struct package *pkg, char *pkg_path); +extern void set_clio(register struct task *newtask); +extern struct param *ppfind(struct pfile *pfp, char *tn, char *pn, int pos, int abbrev); +extern void psetreload(struct pfile *main_pfp, struct param *psetp); +extern void iofinish(register struct task *tp); +extern void restor(struct task *tp); +extern void oneof(void); +extern void printcall(struct _iobuf *fp, struct task *tp); +extern void print_call_line(struct _iobuf *out, int line, char *fname, int flags); +extern void killtask(register struct task *tp); +/* globals.c */ +/* gquery.c */ +extern char *gquery(struct param *pp, char *string); +extern char *minmax(register struct param *pp); +extern char *enumin(register struct param *pp); +/* gram.c */ +extern int yywrap(void); +extern void yyerror(char *s); +extern void rerun(void); +extern int crackident(char *s); +extern XINT addconst(char *s, int t); +extern void listparams(struct pfile *pfp); +extern void pretty_param(struct param *pp, struct _iobuf *fp); +extern void dumpparams(struct pfile *pfp); +extern void show_param(struct ltask *ltp, struct param *pp, struct _iobuf *fp); +extern void listhelp(struct package *pkp, int show_invis); +extern void listallhelp(int show_invis); +extern void breakout(char *full, char **pk, char **t, char **p, char **f); +extern int fieldcvt(register char *f); +extern int keyword(register char *tbl[], register char *s); +extern void intrfunc(char *fname, int nargs); +extern struct operand sexa(char *s); +extern void sexa_to_index(double r, int *i1, int *i2); +extern char *addpipe(void); +extern char *getpipe(void); +extern void delpipes(register int npipes); +extern char *pipefile(int pipecode); +extern void loopincr(void); +extern void loopdecr(void); +extern void setswitch(void); +extern int in_switch(void); +extern void caseset(memel *parg, int ncaseval); +extern struct label *setlabel(struct operand *name); +extern struct label *getlabel(struct operand *name); +extern void setigoto(int loc); +extern void unsetigoto(int loc); +extern int make_imloop(int i1, int i2); +extern int y_typedef(char *key); +extern void p_position(void); +/* history.c */ +extern int yy_getc(struct _iobuf *fp); +extern void yy_startblock(int logflag); +extern char *curcmd(void); +extern int get_command(struct _iobuf *fp); +extern int process_history_directive(char *directive, char *new_command_block); +extern int search_history(char *directive, char *new_command_block); +extern int stredit(char *edit_directive, char *in_text, char *out_text); +extern int expand_history_macros(char *in_text, char *out_text); +extern int get_arglist(char *cmdblk, char *argp[]); +extern void put_history(char *command); +extern int get_history(int record, char *command, int maxch); +extern void fetch_history(char *recptr, char *command, int maxch); +extern char *find_history(int record); +extern void show_history(struct _iobuf *fp, int max_commands); +extern void pprompt(register char *string); +extern void get_prompt(register char *string); +extern void put_logfile(char *command); +extern int open_logfile(char *fname); +extern void close_logfile(char *fname); +extern void reset_logfile(void); +extern int edit_history_directive(char *args, char *new_cmd); +extern void print_command(register struct _iobuf *fp, char *command, char *marg1, char *marg2); +extern char *today(void); +extern int what_record(void); +extern void putlog(struct task *tp, char *usermsg); +/* lexicon.c */ +extern int yylex(void); +extern int lexicon(void); +extern int lexinit(void); +/* lists.c */ +extern struct operand readlist(struct param *pp); +extern void closelist(register struct param *pp); +/* main.c */ +extern int cmain_(int *prtype, short *bkgfile, short *cmd); +extern void clexit(void); +extern void clshutdown(void); +extern char *memneed(int incr); +extern void onint(int *vex, int (**next_handler)(void)); +extern void intr_disable(void); +extern void intr_enable(void); +extern void intr_reset(void); +extern void onerr(void); +extern void cl_amovi(int *ip, int *op, int len); +/* modes.c */ +extern int effmode(struct param *pp); +extern int taskmode(register struct task *tp); +extern void query(struct param *pp); +extern char *nextstr(char **pbuf, struct _iobuf *fp); +extern char *nxtchr(char *p, struct _iobuf *fp); +extern void pquery(register struct param *pp, struct _iobuf *fp); +extern char *bkg_query(char *obuf, int maxch, register struct param *pp); +extern void service_bkgquery(int bkgno); +extern void get_bkgqfiles(int bkgno, int pid, char *bkg_query_file, char *query_response_file); +extern int inrange(register struct param *pp, register struct operand *op); +extern int range_check(struct param *pp); +extern void setclmodes(struct task *tp); +extern void parse_clmodes(struct param *pp, struct operand *newval); +extern int abbrev(void); +extern void poffset(int off); +/* opcodes.c */ +extern void o_undefined(void); +extern void o_absargset(memel *argp); +extern void o_add(void); +extern void o_addassign(memel *argp); +extern void o_allappend(void); +extern void o_allredir(void); +extern void o_and(void); +extern void o_append(void); +extern void o_assign(memel *argp); +extern void o_biff(memel *argp); +extern void o_call(memel *argp); +extern void o_chsign(void); +extern void o_concat(void); +extern void o_div(void); +extern void o_doend(void); +extern void o_divassign(memel *argp); +extern void o_catassign(memel *argp); +extern void o_eq(void); +extern void o_exec(void); +extern void o_ge(void); +extern void o_dogoto(memel *argp); +extern void o_gt(void); +extern void o_indirabsset(memel *argp); +extern void o_indirposset(memel *argp); +extern void o_indxincr(memel *argp); +extern void o_inspect(memel *argp); +extern void o_intrinsic(memel *argp); +extern void o_le(void); +extern void o_lt(void); +extern void o_mul(void); +extern void o_mulassign(memel *argp); +extern void o_ne(void); +extern void o_not(void); +extern void o_or(void); +extern void o_osesc(memel *argp); +extern void o_posargset(memel *argp); +extern void o_dopow(void); +extern void o_doprint(void); +extern void o_immed(void); +extern void o_pushconst(memel *argp); +extern void o_pushindex(int *mode); +extern void o_pushparam(memel *argp); +extern void o_redir(void); +extern void o_redirin(void); +extern void o_gsredir(memel *argp); +extern void o_doaddpipe(memel *argp); +extern void o_dogetpipe(memel *argp); +extern void o_rmpipes(memel *argp); +extern void o_doreturn(void); +extern void o_doscan(void); +extern void o_doscanf(void); +extern void o_dofscan(void); +extern void o_dofscanf(void); +extern void o_sub(void); +extern void o_subassign(memel *argp); +extern void o_doswitch(int *jmpdelta); +extern void o_swoff(memel *argp); +extern void o_swon(memel *argp); +extern void o_fixlanguage(void); +/* operand.c */ +extern void sprop(register char *outstr, register struct operand *op); +extern void spparval(char *outstr, struct param *pp); +extern void fprop(struct _iobuf *fp, struct operand *op); +extern void oprop(struct operand *op); +extern void prop(struct operand *op); +extern void opindir(void); +extern void opcast(int newtype); +extern struct operand makeop(char *str, int type); +/* param.c */ +extern struct param *paramfind(struct pfile *pfp, char *pname, int pos, int exact); +extern void paramset(register struct param *pp, char field); +extern void validparamget(register struct param *pp, char field); +extern void paramget(register struct param *pp, char field); +extern void makemode(struct param *pp, char *s); +extern struct param *newparam(struct pfile *pfp); +extern struct param *paramsrch(char *pkname, char *ltname, char *pname); +extern int defpar(char *param_spec); +extern int defvar(char *envvar); +extern struct param *lookup_param(char *pkname, char *ltname, char *pname); +extern int printparam(struct param *pp, register struct _iobuf *fp); +extern void qputs(register char *str, register struct _iobuf *fp); +extern int pvaldefined(struct param *pp, char *s); +extern struct param *newfakeparam(struct pfile *pfp, char *name, int pos, int type, int string_len); +extern int getoffset(struct param *pp); +extern void offsetmode(int mode); +extern int size_array(struct param *pp); +/* pfiles.c */ +extern struct pfile *newpfile(struct ltask *ltp); +extern void pfileunlink(register struct pfile *pfp); +extern struct pfile *pfilefind(register struct ltask *ltp); +extern struct pfile *pfilesrch(char *pfilepath); +extern struct pfile *pfileload(register struct ltask *ltp); +extern int pfilemerge(struct pfile *npf, char *opfile); +extern void pfileupdate(struct pfile *pfp); +extern struct pfile *pfileread(struct ltask *ltp, char *pfilename, int checkmode); +extern int pfilewrite(struct pfile *pfp, char *pfilename); +extern int pfileinit(struct ltask *ltp); +extern int is_pfilename(char *opstr); +extern void mkpfilename(char *buf, char *dir, char *pkname, char *ltname, char *extn); +extern long filetime(char *fname, char *timecode); +extern struct pfile *pfilecopy(register struct pfile *pfp); +extern void pfcopyback(struct pfile *pff); +extern struct param *addparam(struct pfile *pfp, char *buf, struct _iobuf *fp); +extern int ck_atoi(char *str, int *val); +extern char *nextfield(char **pp, struct _iobuf *fp); +extern char *makelower(register char *cp); +extern int scanmode(char *s); +extern int scantype(register char *s); +/* prcache.c */ +extern int pr_connect(char *process, char *command, struct _iobuf **in, struct _iobuf **out, struct _iobuf *t_in, struct _iobuf *t_out, struct _iobuf *t_err, struct _iobuf *t_gr, struct _iobuf *t_im, struct _iobuf *t_pl, int timeit); +extern void pr_disconnect(int pid); +extern int pr_pconnect(char *process, struct _iobuf **in, struct _iobuf **out); +extern void pr_setcache(int new_szprcache); +extern int pr_cachetask(char *ltname); +extern void pr_lock(register int pid); +extern int pr_unlock(register int pid); +extern void pr_listcache(struct _iobuf *fp); +extern void pr_dumpcache(int pid, int break_locks); +extern void pr_prunecache(int pno); +extern int pr_getpno(void); +extern int pr_pnametopid(char *pname); +extern void pr_chdir(register int pid, char *newdir); +extern void pr_envset(register int pid, char *envvar, char *valuestr); +extern void pr_checkup(void); +extern void pr_initcache(void); +/* scan.c */ +extern void cl_scan(int nargs, char *source); +extern void cl_scanf(char *format, int nargs, char *input); +extern int get_nscanval(void); +extern void lentst(char *buf); +/* stack.c */ +extern void pushmem(memel v); +extern memel popmem(void); +extern void ppushmem(register memel p); +extern struct operand pushop(struct operand *op); +extern struct operand popop(void); +extern struct task *pushtask(void); +extern struct task *poptask(void); +/* task.c */ +extern struct ltask *cmdsrch(char *pkname, char *ltname); +extern struct ltask *ltasksrch(char *pkname, char *ltname); +extern struct ltask *_ltasksrch(char *pkname, char *ltname, struct package **o_pkp); +extern struct package *pacfind(char *name); +extern int defpac(char *pkname); +extern struct ltask *ltaskfind(struct package *pkp, char *name, int enable_abbreviations); +extern int deftask(char *task_spec); +extern void taskunwind(void); +extern struct ltask *addltask(struct package *pkp, char *ptname, char *ltname, int redef); +extern struct ltask *newltask(register struct package *pkp, char *lname, char *pname, struct ltask *oldltp); +extern struct package *newpac(char *name, char *bin); +/* unop.c */ +extern void unop(int opcode); +extern void unexp(int opcode); diff --git a/pkg/cl/scan.c b/pkg/cl/scan.c new file mode 100644 index 00000000..7f7505ff --- /dev/null +++ b/pkg/cl/scan.c @@ -0,0 +1,350 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "config.h" +#include "operand.h" +#include "param.h" +#include "grammar.h" +#include "task.h" +#include "errs.h" +#include "proto.h" + + +/* + * SCAN -- free-format and formatted scan functions. + */ + +extern int cldebug; +extern char *nullstr; +extern char *eofstr; +extern char *indefstr; +extern char *indeflc; + +#define MAXARGS 32 +static int nscan_val=0; /* value returned by NSCAN intrinsic */ + + +/* SCAN -- Perform the bulk of the scan,fscan intrinsic functions to do + * free-formatted reads into nargs params. Formatting is done by makeop() + * according to the type of the corresponding destination param. + * Destination may be "stdout". + * + * Nargs is the number of operands on the stack we need to deal with. + * They are all strings. The scan procedure is actually called to + * process calls to both the SCAN and FSCAN intrinsics. If scan was + * called, the argument "source" will be the string "stdin". If source + * is null, the source is given by the first operand on the stack; it + * may be the special string "stdin". Thereafter, there are exactly + * nargs-1 string operands each of which is the name of a destination + * parameter to be assigned. The operand order must be such that the + * first one popped is the name of the parameter to which the first field + * of the scan line is to be assigned. + * + * EOF or OK is returned as the function value. The number of items + * successfully scanned is returned by a subsequent call to NSCAN(). + * + * query if readlist yields undefined. + * error() may be called on various conditions. + */ +void +cl_scan ( + int nargs, + char *source +) +{ + char buf[SZ_LINE]; + char *bp, *start, c; + char *pk, *t, *p, *f; + char field; + struct operand o; + struct param *pp; + int eoftst; + + eoftst = 0; + + /* Fill buf with the line to be scanned. + */ + if (strcmp (source, "stdin") == 0) { + /* Read from the standard input (SCAN call). + */ + if (fgets (buf, SZ_LINE, currentask->t_stdin) == NULL) + eoftst++; + else + lentst (buf); + /* First arg is an output param, not source, so increment + * nargs. + */ + nargs++; + + } else { + /* Get source name from first operand (FSCAN call) + */ + o = popop(); + if (!strcmp (o.o_val.v_s, "stdin") || + !strcmp (o.o_val.v_s, "STDIN")) { + + if (fgets (buf, SZ_LINE, currentask->t_stdin) == NULL) + eoftst++; + else + lentst (buf); + + } else { + breakout (o.o_val.v_s, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + paramget (pp, *f); + opcast (OT_STRING); + o = popop(); + + if (pp->p_flags & P_LEOF) + eoftst++; + else { + if (opundef (&o)) { + query (pp); /* pushes op */ + opcast (OT_STRING); + o = popop(); + } + strncpy (buf, o.o_val.v_s, SZ_LINE); + } + } + } + + if (eoftst) { + o.o_type = OT_INT; + o.o_val.v_i = CL_EOF; + while (nargs-- > 0) + popop(); /* flush op stack */ + pushop (&o); + return; + } + + /* Take each portion of buf and assign to the given parameter. + */ + bp = buf; + nscan_val = 0; + + while (nargs-- > 0) { /* get each destination name */ + o = popop(); + + if (!strcmp (o.o_val.v_s, "stdout") || + !strcmp (o.o_val.v_s, "STDOUT")) { + pp = NULL; + } else { + breakout (o.o_val.v_s, &pk, &t, &p, &f); + field = *f; + pp = paramsrch (pk, t, p); /* never returns NULL */ + } + + /* Assign rest of line if struct type parameter. For simple + * string or filename type params, the next whitespace delimited + * word is broken out (see below). + */ + if (pp != NULL && + ((pp->p_type & (PT_STRUCT|PT_IMCUR|PT_GCUR|PT_UKEY)) && + !(pp->p_type & (PT_FILNAM|PT_PSET|PT_LIST)))) { + + if (nargs != 0) + cl_error (E_UERR, + "Struct type param must be final Scan argument"); + start = bp; + + } else { + while (*bp == ' ' || *bp == '\t') + bp++; + /* It is not an error if not all params can be filled by scan. + * Simply break off scan, pop the unused args off the stack, + * and return as the function value the number of items + * sucessfully scanned. + */ + if (*bp == '\0') + break; + start = bp; + for (c = *bp; c!=' ' && c!='\t' && c!='\0'; c = *bp) + bp++; + if (c != '\0') + *bp++ = '\0'; + } + + if (pp == NULL) + fputs (start, currentask->t_stdout); + else { + o = makeop (start, pp->p_type & OT_BASIC); + if (opundef (&o)) + break; /* cannot convert as basic type */ + pushop (&o); + paramset (pp, field); + } + + nscan_val++; + } + + /* If we broke out of the above loop because of an unsuccessful + * conversion, we must pop the remaining unused operands off the stack. + */ + while (--nargs >= 0) + popop(); + + o.o_type = OT_INT; + o.o_val.v_i = nscan_val; + pushop (&o); +} + + +/* CL_SCANF -- Formatted scan. Like SCAN except that a C-scanf like format + * statement is used to decode the input text. + */ +void +cl_scanf ( + char *format, + int nargs, + char *input +) +{ + int nscan_val, eoftst, n; + char *pk, *t, *p, *f; + struct operand o; + char buf[SZ_LINE]; + char *v[MAXARGS]; + struct param *pp; + + eoftst = 0; + + /* Fill buf with the line to be scanned. + */ + if (strcmp (input, "stdin") == 0) { + /* Read from the standard input (SCANF). + */ + if (fgets (buf, SZ_LINE, currentask->t_stdin) == NULL) + eoftst++; + else + lentst (buf); + /* First arg is an output param, not source, so increment nargs. */ + nargs++; + + } else { + /* Get source name from first operand (FSCANF). + */ + o = popop(); + + if (!strcmp (o.o_val.v_s, "stdin") || + !strcmp (o.o_val.v_s, "STDIN")) { + + if (fgets (buf, SZ_LINE, currentask->t_stdin) == NULL) + eoftst++; + else + lentst (buf); + + } else { + breakout (o.o_val.v_s, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + paramget (pp, *f); + opcast (OT_STRING); + o = popop(); + + if (pp->p_flags & P_LEOF) + eoftst++; + else { + if (opundef (&o)) { + query (pp); /* pushes op */ + opcast (OT_STRING); + o = popop(); + } + strncpy (buf, o.o_val.v_s, SZ_LINE); + } + } + } + + /* Check for EOF. */ + if (eoftst) { + o.o_type = OT_INT; + o.o_val.v_i = CL_EOF; + while (nargs-- > 0) + popop(); /* flush op stack */ + pushop (&o); + return; + } + + /* Process the stacked operands and build the argument list for + * the scanf call. Each argument pointer points directly to the + * stored parameter value in the parameter descriptor. + */ + for (n=0; --nargs >= 0; n++) { + /* Stacked operand is parameter name. */ + o = popop(); + breakout (o.o_val.v_s, &pk, &t, &p, &f); + pp = paramsrch (pk, t, p); + + /* Add address of parameter value to argument list. First set + * the value with PARAMSET, to make sure that the pset knows + * that the value has been modified. + */ + switch (pp->p_valo.o_type & OT_BASIC) { + case OT_BOOL: + o = makeop ("yes", OT_BOOL); pushop (&o); + paramset (pp, FN_VALUE); + v[n] = (char *) &pp->p_valo.o_val.v_i; + break; + case OT_INT: + o = makeop ("0", OT_INT); pushop (&o); + paramset (pp, FN_VALUE); + v[n] = (char *) &pp->p_valo.o_val.v_i; + break; + case OT_REAL: + o = makeop ("0", OT_REAL); pushop (&o); + paramset (pp, FN_VALUE); + v[n] = (char *) &pp->p_valo.o_val.v_r; + break; + case OT_STRING: + o = makeop ("", OT_STRING); pushop (&o); + paramset (pp, FN_VALUE); + v[n] = (char *) pp->p_valo.o_val.v_s; + break; + default: + cl_error (E_UERR, "scanf: cannot scan into %s\n", o.o_val.v_s); + } + } + + /* Perform the scan. */ + nscan_val = sscanf (buf, format, + v[ 0], v[ 1], v[ 2], v[ 3], v[ 4], v[ 5], v[ 6], v[ 7], + v[ 8], v[ 9], v[10], v[11], v[12], v[13], v[14], v[15], + v[16], v[17], v[18], v[19], v[20], v[21], v[22], v[23], + v[24], v[25], v[26], v[27], v[28], v[29], v[30], v[31]); + + o.o_type = OT_INT; + o.o_val.v_i = nscan_val; + pushop (&o); +} + + +/* GET_NSCANVAL -- Return the number of items successfully scanned in the + * last call to SCAN. + */ +int +get_nscanval (void) +{ + return (nscan_val); +} + + +/* LENTST -- Test that the scan line just read did not overflow the line + * buffer. + */ +void +lentst ( + char *buf +) +{ + char *index(); + char *bp; + + bp = index (buf, '\n'); + if (bp != NULL) + *bp = '\0'; + else + cl_error (E_UERR, "scan limited to %d char lines", SZ_LINE-1); +} diff --git a/pkg/cl/stack.c b/pkg/cl/stack.c new file mode 100644 index 00000000..d3b523b3 --- /dev/null +++ b/pkg/cl/stack.c @@ -0,0 +1,211 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "config.h" +#include "mem.h" +#include "operand.h" +#include "param.h" +#include "task.h" +#include "errs.h" +#include "mem.h" +#include "proto.h" + + +/* + * STACK -- "stack" is actually two stacks: + * starting at the top and growing downwards is the "control stack", + * used for stacking compiler intermediates at compile time and the + * running and any pending task structs at runtime. + * the other, called the "operand stack", starts at the bottom and grows up. + * compiled code is put at its base and basos and topos are set when + * compilation completes to just above the last instruction. at run-time, + * starting at basos and growing upwards, it contains struct operands, + * possibly a string if o_type == OT_STRING, and the index of the last + * operand in a linked-list fashion; see pushop(). when runtime completes, + * its entire contents are disgarded by setting pc = bascode and starting new + * code compilation. + * + * in both cases, the respective "top" values are the indices into "stack" that + * were most recently last assigned. They are not related to the size of the + * object on the stack but always refer simply to the last integer index. + * valid topcs and topos always satisfy: 0 <= topos < topcs < STACKSIZ. + */ + +memel stack[STACKSIZ]; /* control and operand stack combined */ +XINT topcs = STACKSIZ; /* index of last cstack; grows downward */ +XINT topos = -1; /* index of last ostack; grows upward */ +XINT basos = -1; /* lowest legal index of operand stack */ + +/* Push a memel value onto the control stack. Return ERR if it would cause + * overflow, else OK. The control stack is used by the parser during + * compilation. If an error occurs during compilation, taskunwind() will + * call poptask() to pop tasks off the control stack. We must be careful + * to avoid having the compiler temporaries interfere with task frames. + */ +void +pushmem (memel v) +{ + if (topcs - 1 > topos) + stack[--topcs] = v; + else + eprintf ("control stack overflow; topcs/topos = %d/%d\n", + topcs, topos); +} + + +/* Pop top memory value off control stack and return it. + * ==> no real err return, although it is checked. + */ +memel +popmem (void) +{ + if (topcs < STACKSIZ) + return (stack[topcs++]); + else { + eprintf ("control stack underflow\n"); + return ((memel) ERR); + } +} + +/* PPush pushes an element onto the stack, but leaves the top + * of the stack untouched. + */ +void +ppushmem (memel p) +{ + register memel q; + + q = popmem(); + pushmem(p); + pushmem(q); +} + + +/* push operand *op, string storage if o_type == OT_STRING, and last topos + * onto operand stack. + * return copy of new operand so that its o.o_val.v_s will point to the + * stack-stored string; if not string, it will be same as the passed *op. + * call error() if overflow and DO NOT RETURN. + * + * N.B. opcast() uses this layout intimately. + * + * -------------- + * (new) topos -> | last topos | + * |--------------| + * | possible | + * | string | + * | storage |<- + * |--------------| | + * |struct operand| | + * | (o.o_val.v_s)|-- + * |--------------| + * (last topos ->) | last topos | + * |--------------| + * ... + */ +struct operand +pushop (struct operand *op) +{ + struct operand junk; + + if (topos + OPSIZ+1 < topcs) { + int lasttopos = topos; + struct operand *dest; + + dest = (struct operand *) &stack[topos+1]; + *dest = *op; + + if (op->o_type == OT_STRING) { + int len = btoi (strlen (op->o_val.v_s) + 1); + if (topos + OPSIZ+1 + len >= topcs) + goto overflow; + dest->o_val.v_s = (char *) &stack[topos+OPSIZ+1]; + strcpy (dest->o_val.v_s, op->o_val.v_s); + topos += len; + } + + topos += OPSIZ+1; + stack[topos] = lasttopos; + + return (*dest); + } + +overflow: + cl_error (E_IERR, e_soverflow, topcs, topos); + /* NOTREACHED */ + return (junk); +} + +/* pop top operand from stack and return copy of it. If type is string, + * be sure to use it before the next pushop() or the string will get clobbered. + * set topos to top of stack; see diagram with pushop(). + * call error() and do not return if underflow. + */ +struct operand +popop (void) +{ + struct operand junk; + + if (topos > basos) { + struct operand *op; + + topos = stack[topos]; + op = (struct operand *) &stack[topos+1]; + return (*op); + } + cl_error (E_UERR, e_sunderflow); + /* NOTREACHED */ + return (junk); +} + + +/* Create a new, uninitialized, task on the control stack. Call error() + * and don't return if overflow, else return pointer to new entry. Save + * index of new task frame so that we don't get confused by temporaries + * left on the stack by the parser if error occurs during parsing. + */ +int last_task_frame; /* for error recovery */ + +struct task * +pushtask (void) +{ + if (topcs - TASKSIZ > topos) { + topcs -= TASKSIZ; + last_task_frame = topcs; + return ((struct task *) &stack[topcs]); + } + cl_error (E_UERR, "task stack overflow"); /* does not return */ +/* NOTREACHED */ + return ((struct task *) NULL); +} + + +/* Increment topcs and return pointer to next task struct on control stack. + * (Top entry may be inspected with pushtask (poptask()) or with currentask.) + * Call error() and do not return on underflow. + */ +struct task * +poptask (void) +{ + if (topcs <= STACKSIZ - TASKSIZ) { + if (topcs < last_task_frame) { + /* If we get here, something has been pushed on the control + * stack by pop() since the last task frame, which did not + * get cleared off. This may happen if error() is called + * during compilation. + */ + topcs = last_task_frame; + } + topcs += TASKSIZ; + last_task_frame = topcs; + return ((struct task *) &stack[topcs]); + } + cl_error (E_IERR, "Control stack underflow: topcs = %d", topcs); +/* NOTREACHED */ + return ((struct task *) NULL); +} diff --git a/pkg/cl/tags b/pkg/cl/tags new file mode 100644 index 00000000..69a7f15a --- /dev/null +++ b/pkg/cl/tags @@ -0,0 +1,481 @@ +E_DEBUG eparam.c /^#define E_DEBUG(str) e_display(str,cmdline,1) \// +VALU operand.h /^#define VALU(o) (((o)->o_type == OT_REAL) ? (o)->o/ +YYBACKUP ytab.c /^#define YYBACKUP( newtoken, newvalue )\\$/ +YYRECOVERING ytab.c /^#define YYRECOVERING() (!!yyerrflag)$/ +_bkgjob bkg.c /^struct _bkgjob {$/ +_input scan.c /^struct _input {$/ +_ltasksrch task.c /^_ltasksrch (pkname, ltname, o_pkp)$/ +abbrev modes.c /^abbrev ()$/ +addconst gram.c /^addconst (s, t)$/ +addltask task.c /^addltask (pkp, ptname, ltname, redef)$/ +addparam pfiles.c /^addparam (pfp, buf, fp)$/ +addpipe gram.c /^addpipe()$/ +arr_desc operand.h /^struct arr_desc {$/ +arrhead operand.h /^union arrhead {$/ +binexp binop.c /^binexp (opcode)$/ +binop binop.c /^binop (opcode)$/ +bkg_abort bkg.c /^bkg_abort()$/ +bkg_close bkg.c /^bkg_close (job, pmsg)$/ +bkg_delfiles bkg.c /^bkg_delfiles (job)$/ +bkg_init bkg.c /^bkg_init (bcs)$/ +bkg_jobactive bkg.c /^bkg_jobactive (job)$/ +bkg_jobstatus bkg.c /^bkg_jobstatus (fp, job)$/ +bkg_kill bkg.c /^bkg_kill (job)$/ +bkg_query modes.c /^bkg_query (obuf, maxch, pp)$/ +bkg_spawn bkg.c /^bkg_spawn (cmd)$/ +bkg_startup bkg.c /^bkg_startup (bkgfile)$/ +bkg_update bkg.c /^bkg_update (pmsg)$/ +bkg_wait bkg.c /^bkg_wait (job)$/ +bkg_wfservice bkg.c /^bkg_wfservice (job)$/ +bkgfilehdr bkg.c /^struct bkgfilehdr {$/ +breakout gram.c /^breakout (full, pk, t, p, f)$/ +btoi mem.h /^#define btoi(x) ((int)((((x)+BPI-1)\/BPI))) \/* av/ +builtin builtin.c /^ static struct builtin {$/ +busy bkg.c /^#define busy(job) (jobtable[(job)-1].b_flags & J_R/ +c_main main.c /^c_main (prtype, bkgfile)$/ +c_scanmode decl.c /^c_scanmode (pp, o)$/ +callnewtask exec.c /^callnewtask (name)$/ +caseset gram.c /^caseset (parg, ncaseval)$/ +catdstr compile.c /^catdstr (es, ns)$/ +ck_atoi pfiles.c /^ck_atoi (str, val)$/ +cl_amovi main.c /^cl_amovi (ip, op, len)$/ +cl_error errs.c /^cl_error (va_alist)$/ +cl_scan scan.c /^cl_scan (nargs, source)$/ +cl_scanf scan.c /^cl_scanf (format, nargs, input)$/ +clallhelp builtin.c /^clallhelp()$/ +clallocate builtin.c /^clallocate()$/ +clback builtin.c /^clback()$/ +clbeep builtin.c /^clbeep()$/ +clbye builtin.c /^clbye()$/ +clcache builtin.c /^clcache ()$/ +clchdir builtin.c /^clchdir()$/ +clclbye builtin.c /^clclbye()$/ +clclear builtin.c /^clclear()$/ +clcurpack builtin.c /^clcurpack()$/ +cldeallocate builtin.c /^cldeallocate()$/ +cldevstatus builtin.c /^cldevstatus()$/ +cldparam builtin.c /^cldparam()$/ +cledit builtin.c /^cledit()$/ +clehistory builtin.c /^clehistory()$/ +cleparam builtin.c /^cleparam()$/ +clerror builtin.c /^clerror()$/ +clexit main.c /^clexit()$/ +clflprcache builtin.c /^clflprcache()$/ +clforeign builtin.c /^clforeign()$/ +clfprint builtin.c /^clfprint()$/ +clfunc builtin.c /^clfunc()$/ +clgflush builtin.c /^clgflush()$/ +clhelp builtin.c /^clhelp()$/ +clhidetask builtin.c /^clhidetask()$/ +clhistory builtin.c /^clhistory()$/ +cljobs builtin.c /^cljobs()$/ +clkeep builtin.c /^clkeep()$/ +clkill builtin.c /^clkill()$/ +cllogout builtin.c /^cllogout()$/ +cllparam builtin.c /^cllparam()$/ +clntask builtin.c /^clntask()$/ +close_logfile history.c /^close_logfile (fname)$/ +closelist lists.c /^closelist (pp)$/ +clpack builtin.c /^clpack()$/ +clpkg builtin.c /^clpkg()$/ +clprcache builtin.c /^clprcache()$/ +clprint builtin.c /^clprint()$/ +clprintf builtin.c /^clprintf()$/ +clputlog builtin.c /^clputlog()$/ +clreset builtin.c /^clreset()$/ +clrtask builtin.c /^clrtask()$/ +clscanf builtin.c /^clscanf()$/ +clscans builtin.c /^clscans()$/ +clservice builtin.c /^clservice()$/ +clset builtin.c /^clset()$/ +clshow builtin.c /^clshow()$/ +clsleep builtin.c /^clsleep()$/ +clstty builtin.c /^clstty()$/ +clsystem clsystem.c /^clsystem (cmd, taskout, taskerr)$/ +cltask builtin.c /^cltask (redef)$/ +cltime builtin.c /^cltime()$/ +clunlearn builtin.c /^clunlearn()$/ +clupdate builtin.c /^clupdate()$/ +clwait builtin.c /^clwait()$/ +cmd_match edcap.c /^cmd_match (cstring, nchars)$/ +cmdsrch task.c /^cmdsrch (pkname, ltname)$/ +codeentry opcodes.h /^struct codeentry {$/ +coderef mem.h /^#define coderef(x) ((struct codeentry *)&stack[x])/ +comdstr compile.c /^comdstr (s)$/ +compile compile.c /^compile (opcode, args, args2)$/ +comstr compile.c /^comstr (s, loc)$/ +crackident gram.c /^crackident (s)$/ +curcmd history.c /^curcmd()$/ +d_alloc builtin.c /^struct d_alloc {$/ +d_d debug.c /^d_d()$/ +d_f debug.c /^d_f()$/ +d_l debug.c /^d_l()$/ +d_off debug.c /^d_off()$/ +d_on debug.c /^d_on()$/ +d_p debug.c /^d_p()$/ +d_stack debug.c /^d_stack (locpc, ss)$/ +d_t debug.c /^d_t()$/ +daddr mem.h /^#define daddr(x) (&dictionary[x])$/ +dd_f debug.c /^dd_f (msg, fname)$/ +defpac task.c /^defpac (pkname)$/ +defpar param.c /^defpar (param_spec)$/ +deftask task.c /^deftask (task_spec)$/ +delpipes gram.c /^delpipes (npipes)$/ +dereference mem.h /^#define dereference(ptr) \\$/ +do_arrayinit decl.c /^do_arrayinit (pp, nval, nindex)$/ +do_clprint builtin.c /^do_clprint (dest)$/ +do_option decl.c /^do_option (pp, oo, o)$/ +do_scalarinit decl.c /^do_scalarinit (pp, inited)$/ +dtoi mem.h /^#define dtoi(x) ((int)(sizeof(double))\/(sizeof(me/ +dumpparams gram.c /^dumpparams (pfp)$/ +e_check_vals eparam.c /^e_check_vals (string)$/ +e_clear eparam.c /^e_clear()$/ +e_clrerror eparam.c /^e_clrerror ()$/ +e_clrline eparam.c /^e_clrline()$/ +e_colon eparam.c /^e_colon()$/ +e_ctrl eparam.c /^e_ctrl (cap)$/ +e_display eparam.c /^e_display (string, sline, scol)$/ +e_displayml eparam.c /^e_displayml (string, sline, scol, ccol)$/ +e_drawkey eparam.c /^e_drawkey()$/ +e_dumpop debug.c /^e_dumpop()$/ +e_encode_vstring eparam.c /^e_encode_vstring (pp, outbuf)$/ +e_getfield eparam.c /^e_getfield (ip, outstr, maxch)$/ +e_goto eparam.c /^e_goto (col, line)$/ +e_makelist eparam.c /^e_makelist (pfileptr)$/ +e_moreflag eparam.c /^e_moreflag (topkey)$/ +e_movedown eparam.c /^e_movedown (eparam)$/ +e_moveup eparam.c /^e_moveup (eparam)$/ +e_pheader eparam.c /^e_pheader (pfp, cmdline, maxcol)$/ +e_psetok eparam.c /^e_psetok (pset)$/ +e_puterr eparam.c /^e_puterr (errmsg)$/ +e_putline eparam.c /^e_putline (stwing)$/ +e_repaint eparam.c /^e_repaint()$/ +e_rpterror eparam.c /^e_rpterror (errstr)$/ +e_scrollit eparam.c /^e_scrollit()$/ +e_testtop eparam.c /^e_testtop (cur, new)$/ +e_tonextword eparam.c /^e_tonextword (ip)$/ +e_toprevword eparam.c /^e_toprevword (ip, string)$/ +e_ttyexit eparam.c /^e_ttyexit()$/ +e_ttyinit eparam.c /^e_ttyinit()$/ +e_undef eparam.c /^e_undef (s)$/ +echocmds clmodes.h /^#define echocmds() (clecho != NULL && \\$/ +edit_commands eparam.h /^struct edit_commands {$/ +edit_history_directive eparam.c /^edit_history_directive (args, new_cmd)$/ +editstring eparam.c /^editstring (string, eparam)$/ +edtexit edcap.c /^edtexit()$/ +edtinit edcap.c /^edtinit()$/ +effmode modes.c /^effmode (pp)$/ +enumin gquery.c /^enumin (pp)$/ +ep_context eparam.h /^struct ep_context {$/ +eparam eparam.c /^eparam (cx, update, nextcmd, nextpset)$/ +eprintf clprintf.c /^eprintf (va_alist)$/ +epset eparam.c /^epset (pset)$/ +execnewtask exec.c /^execnewtask ()$/ +execute main.c /^execute (mode)$/ +expand_history_macros history.c /^expand_history_macros (in_text, out_text)$/ +fetch_history history.c /^fetch_history (recptr, command, maxch)$/ +fieldcvt gram.c /^fieldcvt (f)$/ +filetime pfiles.c /^filetime (fname, timecode)$/ +find_history history.c /^find_history (record)$/ +findexe exec.c /^findexe (pkg, pkg_path)$/ +fprop operand.c /^fprop (fp, op)$/ +get_arglist history.c /^get_arglist (cmdblk, argp)$/ +get_bkgqfiles modes.c /^get_bkgqfiles (bkgno, pid, bkg_query_file, query_r/ +get_command history.c /^get_command (fp)$/ +get_dim decl.c /^get_dim (pname)$/ +get_editor edcap.c /^get_editor (editor)$/ +get_history history.c /^get_history (record, command, maxch)$/ +get_nscanval scan.c /^get_nscanval()$/ +getlabel gram.c /^getlabel (name)$/ +getlimits decl.c /^getlimits (pname, n, i1, i2)$/ +getoffset param.c /^getoffset(pp)$/ +getpipe gram.c /^getpipe()$/ +gquery gquery.c /^gquery (pp, string)$/ +host_editor edcap.c /^host_editor (editor)$/ +in_switch gram.c /^in_switch()$/ +initparam decl.c /^initparam (op, isparam, type, list)$/ +inrange modes.c /^inrange (pp, op)$/ +int main.c /^typedef int (*PFI)();$/ +intr_disable main.c /^intr_disable()$/ +intr_enable main.c /^intr_enable()$/ +intr_reset main.c /^intr_reset()$/ +intrfunc gram.c /^intrfunc (fname, nargs)$/ +iofinish exec.c /^iofinish (tp)$/ +is_pfilename pfiles.c /^is_pfilename (opstr)$/ +keep builtin.c /^keep (tp)$/ +keeplog clmodes.h /^#define keeplog() (clkeeplog != NULL && \\$/ +keyword gram.c /^keyword (tbl, s)$/ +keywords gram.c /^ struct keywords {$/ +killtask exec.c /^killtask (tp)$/ +label construct.h /^struct label {$/ +lapkg builtin.c /^lapkg()$/ +lentst scan.c /^lentst (buf)$/ +lex_clrcpumode grammar.h /^#define lex_clrcpumode(fp) ((fp)->_fflags &= ~_LEX/ +lex_cpumodeset grammar.h /^#define lex_cpumodeset(fp) ((fp)->_fflags & _LEXBI/ +lex_setcpumode grammar.h /^#define lex_setcpumode(fp) ((fp)->_fflags |= _LEXB/ +lex_yylex lexyy.c /^lex_yylex(){$/ +lexicon lexicon.c /^lexicon()$/ +lexinit lexicon.c /^lexinit()$/ +lexmodes clmodes.h /^#define lexmodes() (cllexmodes != NULL && \\$/ +listallhelp gram.c /^listallhelp (show_invis)$/ +listhelp gram.c /^listhelp (pkp, show_invis)$/ +listparams gram.c /^listparams (pfp)$/ +log_background clmodes.h /^#define log_background() (cllogmode & LOG_BACKGRO/ +log_commands clmodes.h /^#define log_commands() (cllogmode & LOG_COMMANDS)/ +log_errors clmodes.h /^#define log_errors() (cllogmode & LOG_ERRORS)$/ +log_trace clmodes.h /^#define log_trace() (cllogmode & LOG_TRACE)$/ +logfile clmodes.h /^#define logfile() \\$/ +login main.c /^login ()$/ +logout main.c /^logout ()$/ +long config.h /^typedef memel unsigned long; \/* type for dictiona/ +lookup_param param.c /^lookup_param (pkname, ltname, pname)$/ +loopdecr gram.c /^loopdecr()$/ +loopincr gram.c /^loopincr ()$/ +ltask task.h /^struct ltask {$/ +ltaskfind task.c /^ltaskfind (pkp, name, enable_abbreviations)$/ +ltasksrch task.c /^ltasksrch (pkname, ltname)$/ +make_imloop gram.c /^make_imloop (i1, i2)$/ +makelower pfiles.c /^makelower (cp)$/ +makemode param.c /^makemode (pp, s)$/ +makeop operand.c /^makeop (str, type)$/ +maketype decl.c /^maketype (type, list)$/ +map_escapes edcap.c /^map_escapes (input, output)$/ +mapname pfiles.c /^mapname (in, out, maxlen)$/ +memneed main.c /^memneed (incr)$/ +menus clmodes.h /^#define menus() (clmenus != NULL && \\$/ +minmax gquery.c /^minmax (pp)$/ +mk_startupmsg exec.c /^mk_startupmsg (tp, cmd, maxch)$/ +mkarglist builtin.c /^mkarglist (pfp, args, argp)$/ +mkpfilename pfiles.c /^mkpfilename (buf, dir, pkname, ltname, extn)$/ +nargs builtin.c /^nargs (pfp)$/ +newbuiltin builtin.c /^newbuiltin (pkp, lname, fp, flags, ftprefix, redef/ +newfakeparam param.c /^newfakeparam (pfp, name, pos, type, string_len)$/ +newltask task.c /^newltask (pkp, lname, pname, oldltp)$/ +newpac task.c /^newpac (name, bin)$/ +newparam param.c /^newparam (pfp)$/ +newpfile pfiles.c /^newpfile (ltp)$/ +next_task task.h /^#define next_task(tp) ((struct task *)((char *)tp / +nextfield pfiles.c /^nextfield (pp, fp)$/ +nextstr modes.c /^nextstr (pbuf, fp)$/ +notify clmodes.h /^#define notify() (clnotify != NULL && \\$/ +nxtchr modes.c /^nxtchr (p, fp)$/ +o_absargset opcodes.c /^o_absargset (argp)$/ +o_add opcodes.c /^o_add ()$/ +o_addassign opcodes.c /^o_addassign (argp)$/ +o_allappend opcodes.c /^o_allappend ()$/ +o_allredir opcodes.c /^o_allredir ()$/ +o_and opcodes.c /^o_and ()$/ +o_append opcodes.c /^o_append()$/ +o_assign opcodes.c /^o_assign (argp)$/ +o_biff opcodes.c /^o_biff (argp)$/ +o_call opcodes.c /^o_call (argp)$/ +o_catassign opcodes.c /^o_catassign (argp)$/ +o_chsign opcodes.c /^o_chsign ()$/ +o_concat opcodes.c /^o_concat ()$/ +o_div opcodes.c /^o_div ()$/ +o_divassign opcodes.c /^o_divassign (argp)$/ +o_doaddpipe opcodes.c /^o_doaddpipe (argp)$/ +o_doend opcodes.c /^o_doend()$/ +o_dofscan opcodes.c /^o_dofscan()$/ +o_dofscanf opcodes.c /^o_dofscanf()$/ +o_dogetpipe opcodes.c /^o_dogetpipe (argp)$/ +o_dogoto opcodes.c /^o_dogoto (argp)$/ +o_dopow opcodes.c /^o_dopow ()$/ +o_doprint opcodes.c /^o_doprint()$/ +o_doreturn opcodes.c /^o_doreturn()$/ +o_doscan opcodes.c /^o_doscan()$/ +o_doscanf opcodes.c /^o_doscanf()$/ +o_doswitch opcodes.c /^o_doswitch (jmpdelta)$/ +o_eq opcodes.c /^o_eq ()$/ +o_exec opcodes.c /^o_exec ()$/ +o_fixlanguage opcodes.c /^o_fixlanguage()$/ +o_ge opcodes.c /^o_ge ()$/ +o_gsredir opcodes.c /^o_gsredir (argp)$/ +o_gt opcodes.c /^o_gt ()$/ +o_immed opcodes.c /^o_immed()$/ +o_indirabsset opcodes.c /^o_indirabsset (argp)$/ +o_indirposset opcodes.c /^o_indirposset (argp)$/ +o_indxincr opcodes.c /^o_indxincr (argp)$/ +o_inspect opcodes.c /^o_inspect (argp)$/ +o_intrinsic opcodes.c /^o_intrinsic (argp)$/ +o_le opcodes.c /^o_le ()$/ +o_lt opcodes.c /^o_lt ()$/ +o_mul opcodes.c /^o_mul()$/ +o_mulassign opcodes.c /^o_mulassign (argp)$/ +o_ne opcodes.c /^o_ne ()$/ +o_not opcodes.c /^o_not ()$/ +o_or opcodes.c /^o_or()$/ +o_osesc opcodes.c /^o_osesc (argp)$/ +o_posargset opcodes.c /^o_posargset (argp)$/ +o_pushconst opcodes.c /^o_pushconst (argp)$/ +o_pushindex opcodes.c /^o_pushindex (mode)$/ +o_pushparam opcodes.c /^o_pushparam (argp)$/ +o_redir opcodes.c /^o_redir ()$/ +o_redirin opcodes.c /^o_redirin ()$/ +o_rmpipes opcodes.c /^o_rmpipes (argp)$/ +o_sub opcodes.c /^o_sub()$/ +o_subassign opcodes.c /^o_subassign (argp)$/ +o_swoff opcodes.c /^o_swoff (argp)$/ +o_swon opcodes.c /^o_swon (argp)$/ +o_undefined opcodes.c /^o_undefined ()$/ +offsetmode param.c /^offsetmode (mode)$/ +oneof exec.c /^oneof()$/ +onerr main.c /^onerr()$/ +onint main.c /^onint (vex, next_handler)$/ +onipc prcache.c /^onipc (vex, next_handler)$/ +opcast operand.c /^opcast (newtype)$/ +open_logfile history.c /^open_logfile (fname)$/ +operand operand.h /^struct operand {$/ +opindef operand.h /^#define opindef(op) (((op)->o_type & OT_INDEF) != / +opindir operand.c /^opindir()$/ +oprintf clprintf.c /^oprintf (va_alist)$/ +oprop operand.c /^oprop (op)$/ +opundef operand.h /^#define opundef(op) (((op)->o_type & OT_UNDEF) != / +p_position gram.c /^p_position()$/ +pacfind task.c /^pacfind (name)$/ +package task.h /^struct package {$/ +param param.h /^struct param {$/ +paramfind param.c /^paramfind (pfp, pname, pos, exact)$/ +paramget param.c /^paramget (pp, field)$/ +paramset param.c /^paramset (pp, field)$/ +paramsrch param.c /^paramsrch (pkname, ltname, pname)$/ +parse_clmodes modes.c /^parse_clmodes (pp, newval)$/ +pfcopyback pfiles.c /^pfcopyback (pff)$/ +pfile param.h /^struct pfile {$/ +pfilecopy pfiles.c /^pfilecopy (pfp)$/ +pfilefind pfiles.c /^pfilefind (ltp)$/ +pfileinit pfiles.c /^pfileinit (ltp)$/ +pfileload pfiles.c /^pfileload (ltp)$/ +pfilemerge pfiles.c /^pfilemerge (npf, opfile)$/ +pfileread pfiles.c /^pfileread (ltp, pfilename, checkmode)$/ +pfilesrch pfiles.c /^pfilesrch (pfilepath)$/ +pfileunlink pfiles.c /^pfileunlink (pfp)$/ +pfileupdate pfiles.c /^pfileupdate (pfp)$/ +pfilewrite pfiles.c /^pfilewrite (pfp, pfilename)$/ +pipefile gram.c /^pipefile (pipecode)$/ +poffset modes.c /^poffset (off)$/ +pop stack.c /^pop ()$/ +popop stack.c /^popop ()$/ +poptask stack.c /^poptask ()$/ +ppfind exec.c /^ppfind (pfp, tn, pn, pos, abbrev)$/ +pprompt history.c /^pprompt (string)$/ +ppush stack.c /^ppush (p)$/ +pquery modes.c /^pquery (pp, fp)$/ +pr_busy prcache.c /^#define pr_busy(pr) (((pr)->pr_flags&(P_ACTIVE|P_L/ +pr_cachetask prcache.c /^pr_cachetask (ltname)$/ +pr_chdir prcache.c /^pr_chdir (pid, newdir)$/ +pr_checkup prcache.c /^pr_checkup()$/ +pr_connect prcache.c /^pr_connect (process, command, in,out, t_in,t_out,t/ +pr_disconnect prcache.c /^pr_disconnect (pid)$/ +pr_dumpcache prcache.c /^pr_dumpcache (pid, break_locks)$/ +pr_envset prcache.c /^pr_envset (pid, envvar, valuestr)$/ +pr_findproc prcache.c /^pr_findproc (process)$/ +pr_getpno prcache.c /^pr_getpno()$/ +pr_idle prcache.c /^#define pr_idle(pr) (((pr)->pr_flags&P_ACTIVE)==0)/ +pr_initcache prcache.c /^pr_initcache()$/ +pr_listcache prcache.c /^pr_listcache (fp)$/ +pr_lock prcache.c /^pr_lock (pid)$/ +pr_pconnect prcache.c /^pr_pconnect (process, in, out)$/ +pr_pdisconnect prcache.c /^pr_pdisconnect (pr)$/ +pr_pnametopid prcache.c /^pr_pnametopid (pname)$/ +pr_prunecache prcache.c /^pr_prunecache (pno)$/ +pr_setcache prcache.c /^pr_setcache (new_szprcache)$/ +pr_tohead prcache.c /^pr_tohead (pr)$/ +pr_totail prcache.c /^pr_totail (pr)$/ +pr_unlink prcache.c /^pr_unlink (pr)$/ +pretty_param gram.c /^pretty_param (pp, fp)$/ +print_command history.c /^print_command (fp, command, marg1, marg2)$/ +printcall exec.c /^printcall (fp, tp)$/ +printparam param.c /^printparam (pp, fp)$/ +proc_params decl.c /^proc_params (npar)$/ +process prcache.c /^struct process {$/ +process_history_directive history.c /^process_history_directive (directive, new_command_/ +procscript decl.c /^procscript (fp)$/ +prop operand.c /^prop (op)$/ +prparamval clprintf.c /^prparamval (pp, fp)$/ +psetreload exec.c /^psetreload (main_pfp, psetp)$/ +push stack.c /^push (v)$/ +pushbparams builtin.c /^pushbparams (pp)$/ +pushbpvals builtin.c /^pushbpvals (pp)$/ +pushfparams builtin.c /^pushfparams (pp)$/ +pushop stack.c /^pushop (op)$/ +pushtask stack.c /^pushtask ()$/ +put_history history.c /^put_history (command)$/ +put_logfile history.c /^put_logfile (command)$/ +putlog history.c /^putlog (tp, usermsg)$/ +pvaldefined param.c /^pvaldefined (pp, s)$/ +qputs param.c /^qputs (str, fp)$/ +qstrcmp clprintf.c /^qstrcmp (a, b)$/ +query modes.c /^query (pp)$/ +range_check modes.c /^range_check (pp)$/ +rbkgfile bkg.c /^rbkgfile (bkgfile)$/ +readlist lists.c /^readlist (pp)$/ +reference mem.h /^#define reference(sname,index) ((struct sname *) (/ +rerun gram.c /^rerun()$/ +reset_logfile history.c /^reset_logfile()$/ +restor exec.c /^restor (tp)$/ +run exec.c /^run ()$/ +scanenum decl.c /^scanenum (pp, o)$/ +scanftype decl.c /^scanftype (pp, o)$/ +scanlen decl.c /^scanlen (pp, o)$/ +scanmax decl.c /^scanmax (pp, o)$/ +scanmin decl.c /^scanmin (pp, o)$/ +scanmode pfiles.c /^scanmode (s)$/ +scantype pfiles.c /^scantype (s)$/ +search_history history.c /^search_history (directive, new_command_block)$/ +service_bkgquery modes.c /^service_bkgquery (bkgno)$/ +set_clio exec.c /^set_clio (newtask)$/ +setbuiltins builtin.c /^setbuiltins (pkp)$/ +setclmodes modes.c /^setclmodes (tp)$/ +setigoto gram.c /^setigoto (loc)$/ +setlabel gram.c /^setlabel (name)$/ +setopindef operand.h /^#define setopindef(op) ((op)->o_type |= OT_INDEF)$/ +setopundef operand.h /^#define setopundef(op) ((op)->o_type |= OT_UNDEF)$/ +setswitch gram.c /^setswitch ()$/ +sexa gram.c /^struct operand $/ +sexa_to_index gram.c /^sexa_to_index (r, i1, i2)$/ +show_editorhelp edcap.c /^show_editorhelp()$/ +show_history history.c /^show_history (fp, max_commands)$/ +show_param gram.c /^show_param (ltp, pp, fp)$/ +showtype clmodes.h /^#define showtype() (clshowtype != NULL && \\$/ +shutdown main.c /^shutdown()$/ +size_array param.c /^size_array (pp)$/ +skip_to decl.c /^skip_to (fp, key)$/ +spparval operand.c /^spparval (outstr, pp)$/ +sprop operand.c /^sprop (outstr, op)$/ +startup main.c /^startup()$/ +stkop ytab.c /^#define stkop(x) (reference (operand, (x)))$/ +stredit history.c /^stredit (edit_directive, in_text, out_text)$/ +strint binop.c /^strint (s, side)$/ +strsort clprintf.c /^strsort (list, nstr)$/ +strtable clprintf.c /^strtable (fp, list, nstr, first_col, last_col, max/ +task task.h /^struct task {$/ +taskmode modes.c /^taskmode (tp)$/ +taskunwind task.c /^taskunwind()$/ +today history.c /^today()$/ +tprintf clprintf.c /^tprintf (va_alist)$/ +traverse lexyy.c /^traverse (delim)$/ +unexp unop.c /^unexp (opcode)$/ +unop unop.c /^unop (opcode)$/ +unsetigoto gram.c /^unsetigoto (loc)$/ +until config.h /^#define until(x) while (!(x))$/ +validparamget param.c /^validparamget (pp, field)$/ +value operand.h /^union value {$/ +wbkgfile bkg.c /^wbkgfile (jobno, cmd)$/ +what_cmd edcap.c /^what_cmd (first_char)$/ +what_record history.c /^what_record()$/ +y_typedef gram.c /^y_typedef (key)$/ +yy_getc history.c /^yy_getc (fp)$/ +yy_startblock history.c /^yy_startblock (logflag)$/ +yyback lexyy.c /^yyback(p, m)$/ +yyerror gram.c /^yyerror (s)$/ +yyinput lexyy.c /^yyinput(){$/ +yylex lexicon.c /^yylex()$/ +yylook lexyy.c /^yylook(){$/ +yyoutput lexyy.c /^yyoutput(c)$/ +yyparse ytab.c /^yyparse()$/ +yysvf lexyy.c /^struct yysvf { $/ +yytoktype ytab.c /^typedef struct { char *t_name; int t_val; } yytokt/ +yyunput lexyy.c /^yyunput(c)$/ +yywork lexyy.c /^struct yywork { YYTYPE verify, advance; } yycrank[/ +yywrap gram.c /^yywrap ()$/ diff --git a/pkg/cl/task.c b/pkg/cl/task.c new file mode 100644 index 00000000..726c6ab5 --- /dev/null +++ b/pkg/cl/task.c @@ -0,0 +1,580 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#include + +#include "config.h" +#include "operand.h" +#include "param.h" +#include "mem.h" +#include "task.h" +#include "errs.h" +#include "clmodes.h" +#include "proto.h" + + +/* + * TASK -- Operators for tasks. + */ + +extern int cldebug; +extern char *nullstr; +extern struct param *clabbrev; /* used to inhibit abbrevs in addltask */ + +struct task *firstask; /* ptr to original cl task */ +struct task *newtask; /* ptr to new, but unlinked, task */ +struct task *currentask; /* ptr to ltask currently running */ +struct package *curpack; /* current package in effect */ + +XINT pachead; /* dict index of first package */ + + +/* CMDSRCH -- Used by callnewtask() to find the ltask to be run. Ltname is + * the name of the logical task to be run. pkname is the name of an + * explicit package. If pkname is set, just look through its ltasks, + * otherwise circularly search through all packages starting at curpack. + * Once we have found an ltask, we see if there is a package with the same + * (full) name. If there is, we return a pointer to the special pacltask + * with LT_PACCL flag set to signal callnewtask() to just change packages. + * if there isn't, just return a pointer to the ltask. + * Ltasksrch() should be used if you don't want all this package checking... + * Call error() and don't return on any kind of error. + * We need a fake rootpackage entry to be able to change the current package + * to clpackage; see clpkg(). + */ +struct ltask * +cmdsrch ( + char *pkname, + char *ltname +) +{ + register struct ltask *ltp; + register struct package *pkp, *pkcand; + static struct ltask pacltask; /* used to signal a package change */ + struct ltask *temptaskset(); + char *name; + + if (*pkname != '\0') { /* package name included; just search it.*/ + pkp = pacfind (pkname); + if (pkp == NULL) + cl_error (E_UERR, e_pcknonexist, pkname); + else if ((XINT)pkp == ERR) + cl_error (E_UERR, e_pckambig, pkname); + else + ltp = ltaskfind (pkp, ltname, 1); + + if (ltp == NULL) + cl_error (E_UERR, e_tnonexist, ltname); + + if ((XINT)ltp == ERR) + cl_error (E_UERR, e_tambig, ltname); + + } else + /* Search all packages. ltasksrch() does not return if it has + * problems so we can count on ltp being set here. + */ + ltp = ltasksrch ("", ltname); + + /* If this task did not define a package, just go with it. + * Otherwise, search around for package with same name and use it. + * Don't use pacfind() since always want exact matches only. + * If can't find the package now, it must have been existed so we + * should run the task again. + */ + if (!(ltp->lt_flags & LT_DEFPCK)) + return (ltp); + + name = ltp->lt_lname; + pkcand = NULL; + + for (pkp = reference(package,pachead); pkp; pkp = pkp->pk_npk) + if (!strcmp (name, pkp->pk_name)) { + if (pkcand == NULL) + pkcand = pkp; + else + pkcand = (struct package *) ERR; + } + + if (pkcand == (struct package *) ERR) + cl_error (E_UERR, e_pckambig, name); + + if (pkcand == NULL) + return (ltp); + else { + /* Just change to the given package. + * If unions could be inited, we could set lt_flags once in + * its declaration above. phooey. + * Use lt_pkp to return new package. see callnewtask(). + */ + pacltask.lt_flags = (LT_PACCL|LT_CL); + pacltask.lt_pkp = pkcand; + return (&pacltask); + } +} + + +/* LTASKSRCH -- Find ltask of given name along standard path, ie, circularly + * through all packages starting with curpack. If name included package name + * explicitly, it will be in pkname and then just look down it. + * Use abbreviations if enabled. always accept an exact match, even if it + * happened to match more than one longer name as an abbreviation. + * Use cmdsrch() if want to include packages themselves in search path. + * Always return a valid pointer; call error() and don't return on any kind of + * error. + */ +struct ltask * +ltasksrch ( + char *pkname, + char *ltname +) +{ + struct ltask *ltp; + struct package *pkp; + + ltp = _ltasksrch (pkname, ltname, &pkp); + + if (*pkname != EOS) { + if (pkp == NULL) + cl_error (E_UERR, e_pcknonexist, pkname); + if ((int)pkp == ERR) + cl_error (E_UERR, e_pckambig, pkname); + } + + if (ltp == NULL) + cl_error (E_UERR, e_tnonexist, ltname); + if (ltp == (struct ltask *) ERR) + cl_error (E_UERR, e_tambig, ltname); + + return (ltp); +} + + +/* _LTASKSRCH -- Same as ltasksrch(), except that cl_error is not called. + */ +struct ltask * +_ltasksrch ( + char *pkname, + char *ltname, + struct package **o_pkp +) +{ + register struct ltask *ltp, *ltcand; + register struct package *pkp; + register char first_char = ltname[0]; + + ltcand = NULL; + if (*pkname != '\0') { + /* Package name included; just search it. */ + pkp = pacfind (pkname); + if (pkp != NULL && (XINT)pkp != ERR) + ltcand = ltaskfind (pkp, ltname, 1); + + } else if (abbrev()) { + /* Settle for abbreviation. */ + int n = strlen (ltname); + int hit_in_curpack = 0; + + pkp = curpack; + do { + for (ltp = pkp->pk_ltp; ltp; ltp = ltp->lt_nlt) { + if (*ltp->lt_lname == first_char) { + if (!strncmp (ltp->lt_lname, ltname, n)) { + if (ltp->lt_lname[n] == '\0') { /* exact hit */ + *o_pkp = pkp; + return (ltp); + } + /* Only accept exact hits for hidden tasks. + */ + if (ltp->lt_flags & LT_INVIS) + continue; + if (ltcand == NULL) + ltcand = ltp; + else if (!hit_in_curpack) + ltcand = (struct ltask *) ERR; + } + } + } + + /* If an acceptable abbreviation was found in the current + * package, use it, unless an exact match is found in some + * other package. + */ + if (ltcand && pkp == curpack) + hit_in_curpack++; + + /* Circular search. */ + if ((pkp = pkp->pk_npk) == NULL) + pkp = reference (package, pachead); + + } until (pkp == curpack); + + } else { + /* Require exact match */ + pkp = curpack; + do { + for (ltp = pkp->pk_ltp; ltp; ltp = ltp->lt_nlt) + if (*ltp->lt_lname == first_char) + if (!strcmp (ltp->lt_lname, ltname)) + return (ltp); + if ((pkp = pkp->pk_npk) == NULL) + pkp = reference (package, pachead); + } until (pkp == curpack); + } + + *o_pkp = pkp; + return (ltcand); +} + + +/* PACFIND -- Start at pachead and look for package with given name. Allow + * abbreviations if enabled. return ERR if ambiguous. Return its pointer or + * NULL if not found. + */ +struct package * +pacfind ( + char *name +) +{ + struct package *pkp; + struct package *candidate; + int n; + + if (abbrev()) { + /* Settle for abbreviation of name. + * Check whole list in we can find an exact match. + */ + candidate = NULL; + n = strlen (name); + for (pkp = reference(package,pachead); pkp; pkp = pkp->pk_npk) + if (!strncmp (pkp->pk_name, name, n)) { + if (pkp->pk_name[n] == '\0') + return (pkp); /* exact hit */ + if (candidate == NULL) + candidate = pkp; + else + candidate = (struct package *) ERR; + } + + return (candidate); + + } else for (pkp = reference(package,pachead); pkp; pkp = pkp->pk_npk) + if (!strcmp (pkp->pk_name, name)) + return (pkp); + return (NULL); +} + + +/* DEFPAC -- Return true/false if the named package is/isnot loaded. + * Call error if an ambiguous abbreviation is given. + */ +int +defpac ( + char *pkname +) +{ + switch ((XINT)pacfind (pkname)) { + case NULL: + return (NO); + case ERR: + cl_error (E_UERR, e_pckambig, pkname); + default: + return (YES); + } +} + + +/* LTASKFIND -- Start at given package and look for ltask with given name. + * Return NULL if not found, ERR if ambiguous or pointer if found. + */ +struct ltask * +ltaskfind ( + struct package *pkp, /* package to be searched */ + char *name, /* ltask name */ + int enable_abbreviations /* enable abbrev. in search */ +) +{ + register struct ltask *ltp; + struct ltask *candidate; + int n; + + if (enable_abbreviations && abbrev()) { + /* Settle for abbreviation of nam. + * Check whole list in case we can find an exact match. + */ + candidate = NULL; + n = strlen (name); + for (ltp = pkp->pk_ltp; ltp; ltp = ltp->lt_nlt) + if (!strncmp (ltp->lt_lname, name, n)) { + if (ltp->lt_lname[n] == '\0') + return (ltp); /* exact hit */ + if (candidate == NULL) + candidate = ltp; + else + candidate = (struct ltask *) ERR; + } + + return (candidate); + + } else { + /* Accept exact match only. */ + for (ltp = pkp->pk_ltp; ltp; ltp = ltp->lt_nlt) + if (!strcmp (ltp->lt_lname, name)) + return (ltp); + } + + return (NULL); +} + + +/* DEFTASK -- Return true/false if the named ltask is/is not defined. + * If a specific package is named, look only there; otherwise search + * the usual path. Call error if an ambiguous abbreviation is given. + */ +int +deftask ( + char *task_spec +) +{ + char buf[SZ_LINE]; + char *pkname, *ltname, *junk; + struct package *pkp; + int stat; + + strcpy (buf, task_spec); + breakout (buf, &junk, &pkname, <name, &junk); + + if (pkname[0] != '\0') { /* explicit package named */ + if ((pkp = pacfind (pkname)) == NULL) + cl_error (E_UERR, e_pcknonexist, pkname); + if ((stat = (XINT) ltaskfind (pkp, ltname, 1)) == NULL) + return (NO); + + } else { /* search all packages */ + pkp = reference (package, pachead); + stat = NULL; + + while (pkp != NULL) { + stat = (XINT) ltaskfind (pkp, ltname, 1); + if (stat == ERR) + break; + else if (stat != NULL) + return (YES); + pkp = pkp->pk_npk; + } + } + + if (stat == ERR) + cl_error (E_UERR, e_tambig, ltname); + if (stat != NULL) + return (YES); + return (NO); +} + + +/* TASKUNWIND -- Used when aborting from an error or on interrupt, NOT on bye + * or eof. Starting with top task state, keep popping and killing tasks + * until find one that is T_INTERACTIVE, closing files and pipes along the + * way. + * Restore dictionary and stack to what they were when the new (now + * current) task last started compiling with yyparse(). See runtask(). + * Do NOT update parameter files when a task dies abnormally, just from + * a proper "bye" command or eof. + */ +void +taskunwind (void) +{ + while (!(currentask->t_flags & T_INTERACTIVE)) { + killtask (currentask); + currentask = poptask(); + } + + restor (currentask); +} + + +/* ADDLTASK -- Make a new ltask off curpack with given ltname/ptname. + * Check through whole list and warn about redefs unless redef flag is set. + * Look for .cl (script task) or .par (pset task) specs in ptname, and $ + * (no pfile) and trailing .bt (io file type) specs in ltname and set + * lt_flags accordingly. + * Actual new ltask entry made with newltask() and it re-uses dictionary space + * for the ptask name if possible. + * Write error messages here and return ERR if problems, else OK. Be sure they + * use the same format as error() for consistency. + * Do not use abbreviations when checking for possible redefs. + * Newltask() may call error() if it can not get enough core. + * N.B. ptname and ltname may be changed IN PLACE to simplify suffix tests. + */ +struct ltask * +addltask ( + struct package *pkp, + char *ptname, + char *ltname, + int redef +) +{ + register char *cp; + register struct ltask *ltp; + char *rindex(); + char *ltbase; + int flags; + + flags = 0; + ltbase = ltname; + if (*ltbase == '$') + ltbase++; + else + flags |= LT_PFILE; + + /* A leading underscore signifies that the task is not part of the + * user interface, and hence should not appear in menus etc. Set + * the LT_INVIS flag, but leave the underscore in the name. + */ + if (*ltbase == CH_INVIS) + flags |= LT_INVIS; + + /* Check for trailing .bt etc. specs on logical task name. + */ + if ((cp = rindex (ltbase, '.')) != NULL) { + /* replace '.' with '\0' in hopes of finding valid specs. + * if invalid, put back before giving error diagnostic. + */ + *cp++ = '\0'; + if (!strcmp (cp, "pkg")) + flags |= LT_DEFPCK; + else if (!strcmp (cp, "bt")) + flags |= LT_STDINB; + else if (!strcmp (cp, "tb")) + flags |= LT_STDOUTB; + else if (!strcmp (cp, "bb") || !strcmp (cp, "b")) + flags |= (LT_STDOUTB|LT_STDINB); + else if (strcmp (cp, "tt") && strcmp (cp, "t")) { + *--cp = '.'; + eprintf ("ERROR: bad binary io spec in `%s'\n", ltbase); + return (NULL); + } + } + + /* Check to see if this is a redefined task. Inhibit ltaskfind() + * from using abbreviations during redef check. + */ + ltp = ltaskfind (pkp, ltbase, 0); + if (ltp != NULL) { + if (!redef) + eprintf ("WARNING: `%s' is a task redefinition.\n", ltbase); + } else if (redef) + eprintf ("WARNING: `%s' is not a defined task.\n", ltbase); + + /* Check for trailing .cl spec in physical task name to indicate + * a script task, or a .par to indicate a pset task. + */ + if (ptname && (cp = rindex (ptname, '.')) != NULL) { + cp++; + if (!strcmp (cp, "cl")) + flags |= LT_SCRIPT; + else if (!strcmp (cp, "par")) + flags |= (LT_SCRIPT|LT_PSET); + } + + ltp = newltask (pkp, ltbase, ptname, ltp); + ltp->lt_flags = flags; + + return (ltp); +} + + +/* NEWLTASK -- Allocate a new ltask on the dictionary and link in off package + * *pkp. Compile logical name, lname, immediately after. + * Look for and reuse physical name, pname, if possible else compile next. + * this is more than a simple savings of core. all ltasks within a ptask will + * have the same lt_pname pointer so, for example, we can test + * newtask->t_ltp->lt_pname == currentask->t_ltp->lt_pname to decide if the + * next ltask is part of the current ptask. + * Don't do anything with lt_pname if LT_BUILTIN is set since it uses the + * field (in a union) as a pointer to the built-in function. see task.h. + * Link the new ltask immediately off the package at pkp->pk_ltp. this is so + * in a linear search the most recently added task will be seen first. + * For task redefinitions don't allocate a new logical task. Re-use the + * old block and don't change any of the links to the package and other + * tasks. + * Null out all unused fields. + */ +struct ltask * +newltask ( + register struct package *pkp, + char *lname, + char *pname, + struct ltask *oldltp +) +{ + register struct ltask *ltp, *newltp; + + if (oldltp == NULL) { + newltp = (struct ltask *) memneed (LTASKSIZ); + newltp->lt_lname = comdstr (lname); + } else + newltp = oldltp; + + /* Look for another ltask with same pname; use it again if find else + * compile in a new pname. Don't do anything, however, if LT_BUILTIN + * is set as it does not use this union member this way. + */ + if (pname) { + for (ltp = pkp->pk_ltp; ltp != NULL; ltp = ltp->lt_nlt) { + if (!(ltp->lt_flags & LT_BUILTIN)) { + if (strcmp (ltp->lt_pname, pname) == 0) { + newltp->lt_pname = ltp->lt_pname; + goto link; + } + } + } + newltp->lt_pname = comdstr (pname); + } else + newltp->lt_pname = ""; + +link: + if (oldltp == NULL) { + /* Link in as first ltask off this package. + */ + newltp->lt_nlt = pkp->pk_ltp; + pkp->pk_ltp = newltp; + newltp->lt_pkp = pkp; /* set the back-link */ + } + + newltp->lt_flags = 0; + return (newltp); +} + + +/* NEWPAC -- Allocate a new package with given name on the dictionary and + * link in at pachead. compile name in-line immediately after. + * null out all unused fields. + * call error() if no core or if name already exists. + */ +struct package * +newpac ( + char *name, + char *bin +) +{ + register struct package *pkp; + + if (pacfind (name) != NULL) + cl_error (E_UERR, "package `%s' already exists", name); + + pkp = (struct package *) memneed (PACKAGESIZ); + pkp->pk_name = comdstr (name); + pkp->pk_bin = bin ? comdstr(bin) : curpack->pk_bin; + + pkp->pk_npk = reference (package, pachead); + pachead = dereference (pkp); + + pkp->pk_ltp = NULL; + pkp->pk_pfp = NULL; + pkp->pk_flags = 0; + + return (pkp); +} diff --git a/pkg/cl/task.h b/pkg/cl/task.h new file mode 100644 index 00000000..658f248c --- /dev/null +++ b/pkg/cl/task.h @@ -0,0 +1,211 @@ +/* + * TASK.H -- Each time a new task is run, a task struct is pushed onto the top + * of the control stack. The struct is popped off when the task dies. + * This allows recursive task calling. + * + * Each TASK directive creates a new ltask struct at the top of the + * dictionary and gets linked in at the head of the current package, curpack. + * Each PACKAGE directive creates a new package struct at the top of the + * dictionary and gets linked at pachead. + * + * ASSUMES config.h, param.h and stdio.h already include'd. + */ + + +extern struct task *firstask; /* pointer to original cl task */ +extern struct task *newtask; /* new task being prepared for execing; + * not linked in to task list nor does it + * become currentask until run. + */ +extern struct task *currentask; /* the currently running task */ +extern struct package *curpack; /* current package */ + + +/* prevtask may be used as a pointer to the previous, ie, parent, task. + * exploiting c's ability to do pointer arithmetic, it is simple one + * task up from currentask on the control stack. + * this is used alot in the builtin commands to gain access to their parent. + * note that if currentask == firstask, prevtask will point beyond the + * control stack and should not be used. + */ + +/* Added because tp++ will not always be the next task structure. (FJR). + * NOTE -- Must explicitly coerce to char pointer for correct byte arithmetic + * on word (rather than byte) addessed machines. + */ +#define next_task(tp) ((struct task *)((char *)tp + (TASKSIZ*BPI))) + +#define prevtask next_task(currentask) + + +/* ---------- + * info that is needed about a task as it appears on the control stack + * while it is running. + */ +struct task { + FILE *t_stdin, /* where xmit/xfer to stdin/out/err go */ + *t_stdout, + *t_stderr, + *t_stdgraph, /* standard graphics streams */ + *t_stdimage, + *t_stdplot; + FILE *t_in, /* pipe read and write connections */ + *t_out; + char *ft_in; /* stdin file for foreign task */ + char *ft_out; /* stdout file for foreign task */ + char *ft_err; /* stderr file for foreign task */ + struct ltask *t_ltp; /* link back to fostering ltask */ + unsigned XINT + t_topd, /* topd when this task was last pushed */ + t_pc, /* pc " */ + t_topos, /* topos " */ + t_basos, /* basos " */ + t_topcs; /* topcs " */ + XINT t_envp; /* environment stack pointer */ + int t_pno; /* mark package load time in prcache */ + struct package *t_curpack;/* curpack " */ + unsigned t_bascode; /* base addr of currently running code */ + int t_pid; /* process id of this ptask */ + int t_scriptln; /* script line number while parsing */ + struct param *t_modep; /* pointer to this task's `mode' param */ + struct pfile *t_pfp; /* pointer to pfile */ + int t_flags; /* see T_XXX flags below */ +}; + + +/* A leading underscore in the ltask name is used to flag tasks which + * should not appear in the menus. + */ +#define CH_INVIS '_' + +/* t_flags */ +#define T_SCRIPT 00000001 /* means t_ltp->lt_flags & LT_SCRIPT >0*/ +#define T_CL 00000002 /* means that t_ltp == firstask->t_ltp */ +#define T_INTERACTIVE 00000004 /* T_CL && t_stdio == real stdio */ +#define T_BUILTIN 00000010 /* task is built in; see builtin.c */ +#define T_FOREIGN 00000020 /* host task, a type of builtin */ +#define T_PSET 00000040 /* pset (parameter set) task */ +#define T_PKGCL 00000100 /* task is name of a loaded package */ +#define T_CLEOF 00000200 /* cl() with EOF on current stream */ +#define T_TIMEIT 00000400 /* print time consumed by task */ + + +/* These flags are set by the opcodes that change a newtask's pseudofile, + * such as SETSTDOUT. Only when the flag is set will the file then be + * closed by a "bye" or eof from the ltask by clbye(). + */ +#define T_MYOUT 00001000 /* t_stdout was set to exec this task */ +#define T_MYIN 00002000 /* t_stdin " */ +#define T_MYERR 00004000 /* t_stderr " */ +#define T_MYSTDGRAPH 00010000 /* t_stdgraph " */ +#define T_MYSTDIMAGE 00020000 /* t_stdimage " */ +#define T_MYSTDPLOT 00040000 /* t_stdplot " */ +#define T_IPCIO 00100000 /* t_stdout redirected to t_out */ +#define T_STDINB 00200000 /* stdin is binary */ +#define T_STDOUTB 00400000 /* stdout is binary */ +#define T_APPEND 01000000 /* append output of foreign task */ + +/* This flag is set by execnewtask() when a task begins running, and is + * cleared by iofinish() when the task's i/o is closed down. Provided so + * that we can call iofinish at several points during error recovery without + * trying to close files more than once. + */ +#define T_RUNNING 02000000 + +/* When this bit is set we are running unattended as a background cl. + * Seeing this bit on will prevent pfile writes and all errors and signals + * will cause immediate io flushing and exit. + */ +#define T_BATCH 04000000 + +/* IPCIO definitions. */ +#define IPCOUT "IPC$IPCIO-OUT" +#define IPCDONEMSG "# IPC$IPCIO-FINISHED\n" + + +/* Struct LTASK -- One of these is created at the top of the dictionary and + * gets linked in to its package by each ltask named (or implied) in a TASK + * directive. We need the name of the ltask, filename of the ptask, pointer + * to next in list of ltasks on this package, pointer to the parent package + * and misc flags. + * The pointer to the parent package is used to get the prefix for the + * ltask's param file when writing it out locally. Lname is built into the + * directionary right after the structure; pname is re-used if possible by + * looking to see if another ltask exists in the same package with the same + * name. This is more than a savings of core as its the way connect() + * decides if a new ltask is in the currently running ptask (by comparing + * currentask->t_ltp->lt_pname with newtask->t_ltp->lt_pname). + * Note that the ftprefix string cannot be included in the union lt_u as + * a foreign task is a builtin and the ltu_f field is already used to point + * to the builtin to be run to issue the host command. + */ + +struct ltask { + char *lt_lname; /* name of this logical task */ + union { + char *ltu_pname;/* name of this ltask's physical file */ + void (*ltu_f)();/* function to run for this builtin */ + } lt_u; + char *lt_ftprefix; /* OSCMD command prefix for foreign tsk */ + struct ltask *lt_nlt; /* ptr to next ltask in this package */ + struct package *lt_pkp;/* pointer to parent package */ + int lt_flags; /* see LT_XXX flags below */ +}; + +/* alias's for fields in union lt_u. + */ +#define lt_pname lt_u.ltu_pname +#define lt_f lt_u.ltu_f + + +/* lt_flags */ +#define LT_SCRIPT 000001 /* this task is just a script and so is */ + /* the only one in this ptask */ +#define LT_PFILE 000002 /* this task has a pfile (some don't!). */ +#define LT_STDINB 000004 /* set if task's stdin is binary stream */ +#define LT_STDOUTB 000010 /* " stdout " */ +#define LT_BUILTIN 000020 /* task is built into CL */ +#define LT_FOREIGN 000040 /* host task, called with c_oscmd() */ +#define LT_PSET 000100 /* pset (parameter set) task */ +#define LT_INVIS 000200 /* don't show this task in menu */ +#define LT_PACCL 000400 /* changing packages; see callnewtask() */ +#define LT_CL 001000 /* task is some variant of cl() */ +#define LT_CLEOF 002000 /* task is cl with EOF (cleof()) */ +#define LT_DEFPCK 004000 /* the task def'd a pkg with same name */ +#define LT_UPFOK 010000 /* user pfile exists and is valid */ + + +/* ---------- + * A package consists of its name, a pointer to next package (maintained in + * a LIFO fashion off pachead), pointer to first in a list of ltasks in + * this package, pointer to its in-core pfile, and misc flags (not used so far). + * the name string is built into the dictionary directly after the struct. + */ + +struct package { + char *pk_name; /* name of package */ + char *pk_bin; /* package BIN directory */ + struct package *pk_npk; /* ptr to next package */ + struct ltask *pk_ltp; /* ptr to first ltask in pkg */ + struct pfile *pk_pfp; /* ptr to pkg pfile, if loaded */ + int pk_flags; /* package flags */ +}; + +/* pk_flags */ + /* none at present */ + + +/* ---------- + * size of of the task, ltask, and package structs IN INTS. + * this is to properly increment pointers within dictionary. + */ + +#define TASKSIZ btoi (sizeof (struct task)) +#define LTASKSIZ btoi (sizeof (struct ltask)) +#define PACKAGESIZ btoi (sizeof (struct package)) + +struct package *newpac(), *pacfind(); +struct ltask *addltask(), *newltask(), *ltaskfind(), *cmdsrch(); +struct ltask *ltasksrch(), *_ltasksrch(); +struct task *pushtask(), *poptask(); +int deftask(), defpac(); diff --git a/pkg/cl/unop.c b/pkg/cl/unop.c new file mode 100644 index 00000000..45d64b96 --- /dev/null +++ b/pkg/cl/unop.c @@ -0,0 +1,369 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_stdio +#define import_xnames +#define import_math +#include + +#include +#include "config.h" +#include "operand.h" +#include "errs.h" +#include "task.h" +#include "param.h" +#include "proto.h" + +extern int cldebug; + +/* + * UNOP -- Perform unary operations or expressions on one operand. + * + * Always perform the arithmetic in native machine type, eg, don't do integer + * arithmetic by converting to floating and back. + */ + +#define UNSET (-1) /* value not set yet */ + + +/* UNOP -- pop top operand from stack and push back result of performing the + * unary operation whose code is in opcode. An indef operand is not considered + * fatal but is propagated through. Call error() and do not return if find an + * internal error or an undefined string operation. + */ +void +unop (opcode) +int opcode; +{ + register int out_type; /* bool, int, real, string */ + register int in_type; /* bool, int, real, string */ + struct operand o, result; + double rval=0.0, rresult; /* input value, result */ + long ival=0, iresult; + char *sval=NULL, *sresult=NULL; + char fname[SZ_PATHNAME]; + char ch, sbuf[SZ_LINE]; + char *envget(); + int i; + + o = popop(); /* pop operand from stack */ + in_type = o.o_type; + + /* Exit if indefinite and we're not testing for it. */ + if (opindef(&o)) { + if (opcode != OP_ISINDEF) { + result.o_type = OT_INT; + setopindef (&result); + goto pushresult; + } else + in_type = OT_BOOL; + } + + + /* Check that operand is a legal type. Determine the type of the + * result. Set the input value (ival, rval, sval). + */ + + out_type = UNSET; + + switch (opcode) { + case OP_ABS: + case OP_MINUS: + out_type = in_type; + /* fall through */ + + case OP_INT: + case OP_NINT: + if (out_type == UNSET) + out_type = OT_INT; /* force integer result here */ + /* fall through */ + + case OP_COS: + case OP_EXP: + case OP_LOG: + case OP_LOG10: + case OP_SIN: + case OP_SQRT: + case OP_REAL: + case OP_TAN: + case OP_FRAC: + /* Check that an improper operation is not being performed upon + * a string operand. If the output result is int or real, the + * only legal operations are explicit type coercion via the INT + * and REAL intrinsic functions. + */ + if (in_type == OT_STRING) + switch (opcode) { + case OP_INT: + case OP_REAL: + break; + default: + cl_error (E_UERR, e_badstrop, o.o_val.v_s); + } + + if (out_type == UNSET) /* force real result here */ + out_type = OT_REAL; + break; + + case OP_STRLEN: + out_type = OT_INT; + /* fall through */ + + case OP_ACCESS: /* these all require string op */ + case OP_IMACCESS: + case OP_DEFPAC: + case OP_DEFPAR: + case OP_DEFVAR: + case OP_DEFTASK: + if (out_type == UNSET) + out_type = OT_BOOL; + /* fall through */ + + case OP_ENVGET: + case OP_MKTEMP: + case OP_OSFN: + case OP_STRLWR: + case OP_STRUPR: + if (in_type != OT_STRING) + cl_error (E_UERR, "operand must be of type string"); + /* fall through */ + + case OP_STR: + if (out_type == UNSET) + out_type = OT_STRING; + break; + + case OP_ISINDEF: + out_type = OT_BOOL; + break; + + default: + cl_error (E_IERR, e_badsw, opcode, "unop()"); + } + + /* Set the appropriate handy input value variable; check that the + * input type is not a boolean. + */ + switch (in_type) { + case OT_BOOL: + if (opcode == OP_STR) + ival = o.o_val.v_i; /* str(bool) is ok */ + else if (opcode == OP_MINUS) + cl_error (E_UERR, "Arithmetic negation of a boolean operand"); + else if (opcode != OP_ISINDEF) + cl_error (E_UERR, + "Intrinsic function called with illegal boolean argument"); + break; + case OT_INT: + ival = o.o_val.v_i; + rval = (double)ival; + break; + case OT_REAL: + rval = o.o_val.v_r; + if (rval > MAX_LONG || -rval > MAX_LONG) + ival = INDEFL; + else + ival = (long)rval; + break; + case OT_STRING: + sval = o.o_val.v_s; + break; + default: + cl_error (E_IERR, e_badsw, opcode, "unop()"); + } + + /* Perform the operation. + */ + switch (opcode) { + case OP_ABS: + if (out_type == OT_REAL) + rresult = (rval < 0) ? -rval : rval; + else + iresult = (ival < 0) ? -ival : ival; + break; + case OP_ACCESS: + iresult = (c_access (sval, 0, 0) == YES); + break; + case OP_IMACCESS: + iresult = (c_imaccess (sval, 0) == YES); + break; + case OP_COS: + rresult = cos (rval); + break; + case OP_DEFPAC: + iresult = defpac (sval); + break; + case OP_DEFPAR: + iresult = defpar (sval); + break; + case OP_DEFVAR: + iresult = defvar (sval); + break; + case OP_DEFTASK: + iresult = deftask (sval); + break; + case OP_EXP: + rresult = exp (rval); + break; + case OP_FRAC: + if (rval < 0.0e0) { + rresult = -rval; + rresult = -(rresult - (int) rresult); + } else + rresult = rval - (int) rval; + break; + case OP_ISINDEF: + if (in_type == OT_STRING) + iresult = (strcmp (o.o_val.v_s, "INDEF") == 0); + else + iresult = opindef(&o); + break; + case OP_ENVGET: + if ((sresult = envget (sval)) == NULL) + cl_error (E_UERR, "Environment variable '%s' not found", sval); + break; + case OP_OSFN: + c_fmapfn (sval, fname, SZ_PATHNAME); + sresult = fname; + break; + case OP_STRLEN: + iresult = strlen (sval); + break; + case OP_INT: + if (in_type == OT_STRING) { + if (sscanf (sval, "%ld", &iresult) != 1) + cl_error (E_UERR, "Cannot coerce string `%s' to int", sval); + } else + iresult = ival; + break; + case OP_LOG: + if (rval <= 0) + cl_error (E_UERR, "log of a negative or zero argument"); + rresult = log (rval); + break; + case OP_LOG10: + if (rval <= 0) + cl_error (E_UERR, "log10 of a negative or zero argument"); + rresult = log10 (rval); + break; + case OP_MINUS: + if (out_type == OT_REAL) + rresult = -rval; + else + iresult = -ival; + break; + case OP_MKTEMP: + c_mktemp (sval, fname, SZ_PATHNAME); + sresult = fname; + break; + case OP_NINT: + if (in_type == OT_REAL) + iresult = nint (rval); + else + iresult = ival; + break; + case OP_REAL: + if (in_type == OT_STRING) { + if (sscanf (sval, "%lf", &rresult) != 1) + cl_error (E_UERR, + "Cannot coerce string `%s' to real", sval); + } else + rresult = rval; + break; + case OP_SIN: + rresult = sin (rval); + break; + case OP_STR: + pushop (&o); + opcast (OT_STRING); + o = popop(); + sresult = o.o_val.v_s; + break; + case OP_STRLWR: + for (i=0; (ch = o.o_val.v_s[i]) != EOS; i++) + sbuf[i] = tolower (ch); + sbuf[i] = EOS; + sresult = sbuf; + break; + case OP_STRUPR: + for (i=0; (ch = o.o_val.v_s[i]) != EOS; i++) + sbuf[i] = toupper (ch); + sbuf[i] = EOS; + sresult = sbuf; + break; + case OP_SQRT: + if (rval < 0) + cl_error (E_UERR, "sqrt of a negative number"); + rresult = sqrt (rval); + break; + case OP_TAN: + rresult = tan (rval); + break; + + default: + cl_error (E_IERR, e_badsw, opcode, "unop()"); + } + + switch (out_type) { + case OT_BOOL: + case OT_INT: + result.o_val.v_i = iresult; + break; + case OT_REAL: + result.o_val.v_r = rresult; + break; + case OT_STRING: + result.o_val.v_s = sresult; + break; + default: + cl_error (E_UERR, "illegal datatype in intrinsic"); + } + result.o_type = out_type; + +pushresult: + pushop (&result); +} + + +/* UNEXP -- Pop top operand and replace with boolean result operand of applying + * logical operation in opcode. + * Result is always an operand with o_type OP_BOOL and o_val.v_i as + * returned from relation. + * Propagate bad operands through, but call error() and do not return + * on internal errors or undefined operations. + * It is illegal to perform a boolean operation on a non-boolean operand; + * there is no automatic type coercion for booleans. + */ +void +unexp (opcode) +int opcode; +{ + struct operand o, result; + int type; + + o = popop(); + type = o.o_type; + + if (opindef (&o)) { + result.o_type = OT_BOOL; + setopindef (&result); + goto pushresult; + } + + switch (opcode) { + case OP_NOT: + if (type != OT_BOOL) + cl_error (E_UERR, "Boolean negation of a non-boolean operand"); + result.o_val.v_i = !o.o_val.v_i; + break; + default: + cl_error (E_IERR, e_badsw, opcode, "unexp()"); + } + + result.o_type = OT_BOOL; + +pushresult: + pushop (&result); +} diff --git a/pkg/cl/y.output b/pkg/cl/y.output new file mode 100644 index 00000000..7f3f6ceb --- /dev/null +++ b/pkg/cl/y.output @@ -0,0 +1,6737 @@ +State 0 conflicts: 1 shift/reduce +State 86 conflicts: 1 shift/reduce +State 89 conflicts: 1 shift/reduce +State 99 conflicts: 1 shift/reduce +State 179 conflicts: 1 shift/reduce +State 250 conflicts: 1 shift/reduce +State 298 conflicts: 1 shift/reduce +State 359 conflicts: 2 shift/reduce + + +Grammar + + 0 $accept: block $end + + 1 block: /* empty */ + 2 | '.' NL + + 3 @1: /* empty */ + + 4 block: block @1 debug xstmt + 5 | script_params + 6 | script_body + 7 | error NL + + 8 debug: /* empty */ + + 9 @2: /* empty */ + + 10 debug: D_XXX EOST @2 debug + + 11 D_XXX: D_D + 12 | D_PEEK Y_CONSTANT + 13 | '~' + + 14 script_params: proc_stmt var_decls begin_stmt + + 15 @3: /* empty */ + + 16 script_body: begin_stmt @3 s_list opnl end_stmt + + 17 @4: /* empty */ + + 18 proc_stmt: Y_PROCEDURE @4 param bparam_list EOST + + 19 bparam_list: /* empty */ + 20 | LP param_list RP + + 21 param_list: /* empty */ + 22 | xparam_list + + 23 xparam_list: param + 24 | xparam_list DELIM param + + 25 var_decls: /* empty */ + 26 | var_decl_block + + 27 var_decl_block: var_decl_line + 28 | var_decl_block var_decl_line + + 29 var_decl_line: EOST + 30 | var_decl_stmt + 31 | error NL + + 32 @5: /* empty */ + + 33 var_decl_stmt: typedefs @5 var_decl_list EOST + + 34 typedefs: Y_BOOL + 35 | Y_STRING + 36 | Y_REAL + 37 | Y_FILE + 38 | Y_GCUR + 39 | Y_IMCUR + 40 | Y_UKEY + 41 | Y_PSET + 42 | Y_INT + 43 | Y_STRUCT + + 44 var_decl_list: var_decl_plus + 45 | var_decl_plus DELIM var_decl_list + + 46 var_decl_plus: var_decl + 47 | var_decl '{' options_list ';' '}' + + 48 var_decl: var_def + + 49 @6: /* empty */ + + 50 var_decl: var_def '=' @6 init_list + + 51 var_def: var_name + + 52 @7: /* empty */ + + 53 var_def: var_name @7 '[' init_index_list ']' + + 54 var_name: param + 55 | '*' param + + 56 init_index_list: /* empty */ + 57 | init_index_range + 58 | init_index_list DELIM init_index_range + + 59 init_index_range: const + 60 | const ':' const + + 61 init_list: init_elem + 62 | init_list DELIM init_elem + + 63 init_elem: const + 64 | Y_CONSTANT LP const RP + + 65 const: Y_CONSTANT + 66 | number + + 67 number: sign Y_CONSTANT + + 68 sign: '+' + 69 | '-' + + 70 options_list: init_list DELIM options + 71 | init_list + 72 | options + + 73 options: option + 74 | options DELIM option + + 75 option: Y_IDENT '=' const + + 76 begin_stmt: Y_BEGIN NL + + 77 expr: expr0 + 78 | ref + + 79 expr0: expr1 + 80 | Y_CONSTANT + 81 | Y_GCUR + 82 | Y_IMCUR + 83 | Y_UKEY + 84 | Y_PSET + + 85 expr1: LP expr RP + 86 | expr '+' opnl expr + 87 | expr '-' opnl expr + 88 | expr '*' opnl expr + 89 | expr '/' opnl expr + 90 | expr YOP_POW opnl expr + 91 | expr '%' opnl expr + 92 | expr YOP_CONCAT opnl expr + 93 | expr '<' opnl expr + 94 | expr '>' opnl expr + 95 | expr YOP_LE opnl expr + 96 | expr YOP_GE opnl expr + 97 | expr YOP_EQ opnl expr + 98 | expr YOP_NE opnl expr + 99 | expr YOP_OR opnl expr + 100 | expr YOP_AND opnl expr + 101 | YOP_NOT expr + 102 | '-' expr + + 103 @8: /* empty */ + + 104 expr1: Y_SCAN LP @8 scanarg RP + + 105 @9: /* empty */ + + 106 expr1: Y_SCANF LP @9 scanfmt DELIM scanarg RP + + 107 @10: /* empty */ + + 108 expr1: Y_FSCAN LP @10 scanarg RP + + 109 @11: /* empty */ + + 110 expr1: Y_FSCANF LP Y_IDENT DELIM @11 scanfmt DELIM scanarg RP + + 111 @12: /* empty */ + + 112 expr1: intrinsx LP @12 intrarg RP + + 113 intrinsx: intrins + 114 | Y_INT + 115 | Y_REAL + + 116 scanfmt: expr + + 117 scanarg: /* empty */ + 118 | Y_IDENT + 119 | Y_IDENT DELIM scanarg + + 120 intrarg: /* empty */ + 121 | expr + 122 | intrarg DELIM expr + + 123 stmt: c_stmt + 124 | assign EOST + 125 | cmdlist EOST + 126 | immed EOST + 127 | inspect EOST + 128 | osesc EOST + 129 | popstk EOST + 130 | if + 131 | ifelse + 132 | while + 133 | for + 134 | switch + 135 | case + 136 | default + 137 | next EOST + 138 | break EOST + 139 | goto EOST + 140 | return EOST + 141 | label_stmt + 142 | nullstmt + + 143 c_stmt: c_blk + 144 | c_blk NL + + 145 @13: /* empty */ + + 146 @14: /* empty */ + + 147 c_blk: '{' @13 s_list opnl @14 '}' + + 148 s_list: /* empty */ + 149 | s_list opnl xstmt + + 150 assign: ref equals expr0 + 151 | ref equals ref + + 152 @15: /* empty */ + + 153 assign: ref @15 assign_oper expr + + 154 equals: '=' + + 155 assign_oper: YOP_AOADD + 156 | YOP_AOSUB + 157 | YOP_AOMUL + 158 | YOP_AODIV + 159 | YOP_AOCAT + + 160 @16: /* empty */ + + 161 cmdlist: command @16 cmdpipe + + 162 cmdpipe: /* empty */ + + 163 @17: /* empty */ + + 164 cmdpipe: cmdpipe pipe @17 command + + 165 pipe: '|' opnl + 166 | Y_ALLPIPE opnl + + 167 @18: /* empty */ + + 168 @19: /* empty */ + + 169 command: tasknam @18 BARG @19 args EARG + + 170 @20: /* empty */ + + 171 args: DELIM @20 arglist + 172 | arglist + + 173 arglist: arg + 174 | arglist DELIM arg + + 175 arg: /* empty */ + 176 | expr0 + 177 | ref + 178 | ref '=' expr0 + 179 | ref '=' ref + 180 | param '+' + 181 | param '-' + 182 | '<' file + 183 | '>' file + 184 | Y_ALLREDIR file + 185 | Y_APPEND file + 186 | Y_ALLAPPEND file + 187 | Y_GSREDIR file + + 188 file: expr0 + 189 | param + + 190 immed: equals expr0 + 191 | equals ref + + 192 inspect: ref equals + + 193 osesc: Y_OSESC + + 194 popstk: equals + + 195 if: if_stat + + 196 @21: /* empty */ + + 197 if_stat: Y_IF LP expr RP @21 opnl xstmt + + 198 @22: /* empty */ + + 199 ifelse: if_stat Y_ELSE @22 opnl xstmt + + 200 @23: /* empty */ + + 201 @24: /* empty */ + + 202 while: Y_WHILE LP @23 expr RP @24 opnl xstmt + + 203 @25: /* empty */ + + 204 @26: /* empty */ + + 205 @27: /* empty */ + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 xexpr ';' opnl @26 xassign RP opnl @27 stmt + + 207 xassign: assign + 208 | /* empty */ + + 209 xexpr: expr + 210 | /* empty */ + + 211 @28: /* empty */ + + 212 switch: Y_SWITCH opnl LP opnl expr opnl RP opnl @28 xstmt + + 213 @29: /* empty */ + + 214 @30: /* empty */ + + 215 case: Y_CASE @29 const_expr_list ':' opnl @30 xstmt + + 216 @31: /* empty */ + + 217 default: Y_DEFAULT ':' opnl @31 xstmt + + 218 next: Y_NEXT + + 219 break: Y_BREAK + + 220 return: Y_RETURN + 221 | Y_RETURN expr + + 222 end_stmt: Y_END NL + + 223 @32: /* empty */ + + 224 label_stmt: Y_IDENT ':' opnl @32 xstmt + + 225 goto: Y_GOTO Y_IDENT + + 226 nullstmt: ';' + 227 | ';' NL + + 228 @33: /* empty */ + + 229 xstmt: @33 stmt + 230 | var_decl_stmt + 231 | error NL + + 232 const_expr_list: const_expr + 233 | const_expr DELIM const_expr_list + + 234 const_expr: Y_CONSTANT + + 235 opnl: /* empty */ + 236 | NL + + 237 ref: param + + 238 @34: /* empty */ + + 239 ref: param @34 '[' index_list ']' + + 240 index_list: index + + 241 @35: /* empty */ + + 242 index_list: index @35 DELIM index_list + + 243 index: expr1 + 244 | ref + 245 | '*' + 246 | Y_CONSTANT + + 247 intrins: Y_IDENT + + 248 param: Y_IDENT + + 249 tasknam: Y_IDENT + + 250 EOST: NL + 251 | ';' + + 252 DELIM: ',' + + 253 BARG: /* empty */ + 254 | LP + + 255 EARG: /* empty */ + 256 | RP + + 257 LP: '(' + + 258 RP: ')' + + 259 NL: Y_NEWLINE + + +Terminals, with rules where they appear + +$end (0) 0 +'%' (37) 91 +'(' (40) 257 +')' (41) 258 +'*' (42) 55 88 245 +'+' (43) 68 86 180 +',' (44) 252 +'-' (45) 69 87 102 181 +'.' (46) 2 +'/' (47) 89 +':' (58) 60 215 217 224 +';' (59) 47 206 226 227 251 +'<' (60) 93 182 +'=' (61) 50 75 154 178 179 +'>' (62) 94 183 +'[' (91) 53 239 +']' (93) 53 239 +'{' (123) 47 147 +'|' (124) 165 +'}' (125) 47 147 +'~' (126) 13 +error (256) 7 31 231 +Y_SCAN (258) 104 +Y_SCANF (259) 106 +Y_FSCAN (260) 108 +Y_FSCANF (261) 110 +Y_OSESC (262) 193 +Y_APPEND (263) 185 +Y_ALLAPPEND (264) 186 +Y_ALLREDIR (265) 184 +Y_GSREDIR (266) 187 +Y_ALLPIPE (267) 166 +D_D (268) 11 +D_PEEK (269) 12 +Y_NEWLINE (270) 259 +Y_CONSTANT (271) 12 64 65 67 80 234 246 +Y_IDENT (272) 75 110 118 119 224 225 247 248 249 +Y_WHILE (273) 202 +Y_IF (274) 197 +Y_ELSE (275) 199 +Y_FOR (276) 206 +Y_BREAK (277) 219 +Y_NEXT (278) 218 +Y_SWITCH (279) 212 +Y_CASE (280) 215 +Y_DEFAULT (281) 217 +Y_RETURN (282) 220 221 +Y_GOTO (283) 225 +Y_PROCEDURE (284) 18 +Y_BEGIN (285) 76 +Y_END (286) 222 +Y_BOOL (287) 34 +Y_INT (288) 42 114 +Y_REAL (289) 36 115 +Y_STRING (290) 35 +Y_FILE (291) 37 +Y_STRUCT (292) 43 +Y_GCUR (293) 38 81 +Y_IMCUR (294) 39 82 +Y_UKEY (295) 40 83 +Y_PSET (296) 41 84 +YOP_AOCAT (297) 159 +YOP_AODIV (298) 158 +YOP_AOMUL (299) 157 +YOP_AOSUB (300) 156 +YOP_AOADD (301) 155 +YOP_OR (302) 99 +YOP_AND (303) 100 +YOP_NE (304) 98 +YOP_EQ (305) 97 +YOP_GE (306) 96 +YOP_LE (307) 95 +YOP_CONCAT (308) 92 +UMINUS (309) +YOP_NOT (310) 101 +YOP_POW (311) 90 + + +Nonterminals, with rules where they appear + +$accept (77) + on left: 0 +block (78) + on left: 1 2 4 5 6 7, on right: 0 4 +@1 (79) + on left: 3, on right: 4 +debug (80) + on left: 8 10, on right: 4 10 +@2 (81) + on left: 9, on right: 10 +D_XXX (82) + on left: 11 12 13, on right: 10 +script_params (83) + on left: 14, on right: 5 +script_body (84) + on left: 16, on right: 6 +@3 (85) + on left: 15, on right: 16 +proc_stmt (86) + on left: 18, on right: 14 +@4 (87) + on left: 17, on right: 18 +bparam_list (88) + on left: 19 20, on right: 18 +param_list (89) + on left: 21 22, on right: 20 +xparam_list (90) + on left: 23 24, on right: 22 24 +var_decls (91) + on left: 25 26, on right: 14 +var_decl_block (92) + on left: 27 28, on right: 26 28 +var_decl_line (93) + on left: 29 30 31, on right: 27 28 +var_decl_stmt (94) + on left: 33, on right: 30 230 +@5 (95) + on left: 32, on right: 33 +typedefs (96) + on left: 34 35 36 37 38 39 40 41 42 43, on right: 33 +var_decl_list (97) + on left: 44 45, on right: 33 45 +var_decl_plus (98) + on left: 46 47, on right: 44 45 +var_decl (99) + on left: 48 50, on right: 46 47 +@6 (100) + on left: 49, on right: 50 +var_def (101) + on left: 51 53, on right: 48 50 +@7 (102) + on left: 52, on right: 53 +var_name (103) + on left: 54 55, on right: 51 53 +init_index_list (104) + on left: 56 57 58, on right: 53 58 +init_index_range (105) + on left: 59 60, on right: 57 58 +init_list (106) + on left: 61 62, on right: 50 62 70 71 +init_elem (107) + on left: 63 64, on right: 61 62 +const (108) + on left: 65 66, on right: 59 60 63 64 75 +number (109) + on left: 67, on right: 66 +sign (110) + on left: 68 69, on right: 67 +options_list (111) + on left: 70 71 72, on right: 47 +options (112) + on left: 73 74, on right: 70 72 74 +option (113) + on left: 75, on right: 73 74 +begin_stmt (114) + on left: 76, on right: 14 16 +expr (115) + on left: 77 78, on right: 85 86 87 88 89 90 91 92 93 94 95 96 97 + 98 99 100 101 102 116 121 122 153 197 202 209 212 221 +expr0 (116) + on left: 79 80 81 82 83 84, on right: 77 150 176 178 188 190 +expr1 (117) + on left: 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 + 104 106 108 110 112, on right: 79 243 +@8 (118) + on left: 103, on right: 104 +@9 (119) + on left: 105, on right: 106 +@10 (120) + on left: 107, on right: 108 +@11 (121) + on left: 109, on right: 110 +@12 (122) + on left: 111, on right: 112 +intrinsx (123) + on left: 113 114 115, on right: 112 +scanfmt (124) + on left: 116, on right: 106 110 +scanarg (125) + on left: 117 118 119, on right: 104 106 108 110 119 +intrarg (126) + on left: 120 121 122, on right: 112 122 +stmt (127) + on left: 123 124 125 126 127 128 129 130 131 132 133 134 135 136 + 137 138 139 140 141 142, on right: 206 229 +c_stmt (128) + on left: 143 144, on right: 123 +c_blk (129) + on left: 147, on right: 143 144 +@13 (130) + on left: 145, on right: 147 +@14 (131) + on left: 146, on right: 147 +s_list (132) + on left: 148 149, on right: 16 147 149 +assign (133) + on left: 150 151 153, on right: 124 207 +@15 (134) + on left: 152, on right: 153 +equals (135) + on left: 154, on right: 150 151 190 191 192 194 +assign_oper (136) + on left: 155 156 157 158 159, on right: 153 +cmdlist (137) + on left: 161, on right: 125 +@16 (138) + on left: 160, on right: 161 +cmdpipe (139) + on left: 162 164, on right: 161 164 +@17 (140) + on left: 163, on right: 164 +pipe (141) + on left: 165 166, on right: 164 +command (142) + on left: 169, on right: 161 164 +@18 (143) + on left: 167, on right: 169 +@19 (144) + on left: 168, on right: 169 +args (145) + on left: 171 172, on right: 169 +@20 (146) + on left: 170, on right: 171 +arglist (147) + on left: 173 174, on right: 171 172 174 +arg (148) + on left: 175 176 177 178 179 180 181 182 183 184 185 186 187, + on right: 173 174 +file (149) + on left: 188 189, on right: 182 183 184 185 186 187 +immed (150) + on left: 190 191, on right: 126 +inspect (151) + on left: 192, on right: 127 +osesc (152) + on left: 193, on right: 128 +popstk (153) + on left: 194, on right: 129 +if (154) + on left: 195, on right: 130 +if_stat (155) + on left: 197, on right: 195 199 +@21 (156) + on left: 196, on right: 197 +ifelse (157) + on left: 199, on right: 131 +@22 (158) + on left: 198, on right: 199 +while (159) + on left: 202, on right: 132 +@23 (160) + on left: 200, on right: 202 +@24 (161) + on left: 201, on right: 202 +for (162) + on left: 206, on right: 133 +@25 (163) + on left: 203, on right: 206 +@26 (164) + on left: 204, on right: 206 +@27 (165) + on left: 205, on right: 206 +xassign (166) + on left: 207 208, on right: 206 +xexpr (167) + on left: 209 210, on right: 206 +switch (168) + on left: 212, on right: 134 +@28 (169) + on left: 211, on right: 212 +case (170) + on left: 215, on right: 135 +@29 (171) + on left: 213, on right: 215 +@30 (172) + on left: 214, on right: 215 +default (173) + on left: 217, on right: 136 +@31 (174) + on left: 216, on right: 217 +next (175) + on left: 218, on right: 137 +break (176) + on left: 219, on right: 138 +return (177) + on left: 220 221, on right: 140 +end_stmt (178) + on left: 222, on right: 16 +label_stmt (179) + on left: 224, on right: 141 +@32 (180) + on left: 223, on right: 224 +goto (181) + on left: 225, on right: 139 +nullstmt (182) + on left: 226 227, on right: 142 +xstmt (183) + on left: 229 230 231, on right: 4 149 197 199 202 212 215 217 224 +@33 (184) + on left: 228, on right: 229 +const_expr_list (185) + on left: 232 233, on right: 215 233 +const_expr (186) + on left: 234, on right: 232 233 +opnl (187) + on left: 235 236, on right: 16 86 87 88 89 90 91 92 93 94 95 96 + 97 98 99 100 147 149 165 166 197 199 202 206 212 215 217 224 +ref (188) + on left: 237 239, on right: 78 150 151 153 177 178 179 191 192 + 244 +@34 (189) + on left: 238, on right: 239 +index_list (190) + on left: 240 242, on right: 239 242 +@35 (191) + on left: 241, on right: 242 +index (192) + on left: 243 244 245 246, on right: 240 242 +intrins (193) + on left: 247, on right: 113 +param (194) + on left: 248, on right: 18 23 24 54 55 180 181 189 237 239 +tasknam (195) + on left: 249, on right: 169 +EOST (196) + on left: 250 251, on right: 10 18 29 33 124 125 126 127 128 129 + 137 138 139 140 +DELIM (197) + on left: 252, on right: 24 45 58 62 70 74 106 110 119 122 171 174 + 233 242 +BARG (198) + on left: 253 254, on right: 169 +EARG (199) + on left: 255 256, on right: 169 +LP (200) + on left: 257, on right: 20 64 85 104 106 108 110 112 197 202 206 + 212 254 +RP (201) + on left: 258, on right: 20 64 85 104 106 108 110 112 197 202 206 + 212 256 +NL (202) + on left: 259, on right: 2 7 31 76 144 222 227 231 236 250 + + +state 0 + + 0 $accept: . block $end + + error shift, and go to state 1 + Y_PROCEDURE shift, and go to state 2 + Y_BEGIN shift, and go to state 3 + '.' shift, and go to state 4 + + $end reduce using rule 1 (block) + error [reduce using rule 1 (block)] + Y_OSESC reduce using rule 1 (block) + D_D reduce using rule 1 (block) + D_PEEK reduce using rule 1 (block) + Y_IDENT reduce using rule 1 (block) + Y_WHILE reduce using rule 1 (block) + Y_IF reduce using rule 1 (block) + Y_FOR reduce using rule 1 (block) + Y_BREAK reduce using rule 1 (block) + Y_NEXT reduce using rule 1 (block) + Y_SWITCH reduce using rule 1 (block) + Y_CASE reduce using rule 1 (block) + Y_DEFAULT reduce using rule 1 (block) + Y_RETURN reduce using rule 1 (block) + Y_GOTO reduce using rule 1 (block) + Y_BOOL reduce using rule 1 (block) + Y_INT reduce using rule 1 (block) + Y_REAL reduce using rule 1 (block) + Y_STRING reduce using rule 1 (block) + Y_FILE reduce using rule 1 (block) + Y_STRUCT reduce using rule 1 (block) + Y_GCUR reduce using rule 1 (block) + Y_IMCUR reduce using rule 1 (block) + Y_UKEY reduce using rule 1 (block) + Y_PSET reduce using rule 1 (block) + '=' reduce using rule 1 (block) + '~' reduce using rule 1 (block) + '{' reduce using rule 1 (block) + ';' reduce using rule 1 (block) + + block go to state 5 + script_params go to state 6 + script_body go to state 7 + proc_stmt go to state 8 + begin_stmt go to state 9 + + +state 1 + + 7 block: error . NL + + Y_NEWLINE shift, and go to state 10 + + NL go to state 11 + + +state 2 + + 18 proc_stmt: Y_PROCEDURE . @4 param bparam_list EOST + + $default reduce using rule 17 (@4) + + @4 go to state 12 + + +state 3 + + 76 begin_stmt: Y_BEGIN . NL + + Y_NEWLINE shift, and go to state 10 + + NL go to state 13 + + +state 4 + + 2 block: '.' . NL + + Y_NEWLINE shift, and go to state 10 + + NL go to state 14 + + +state 5 + + 0 $accept: block . $end + 4 block: block . @1 debug xstmt + + $end shift, and go to state 15 + + $default reduce using rule 3 (@1) + + @1 go to state 16 + + +state 6 + + 5 block: script_params . + + $default reduce using rule 5 (block) + + +state 7 + + 6 block: script_body . + + $default reduce using rule 6 (block) + + +state 8 + + 14 script_params: proc_stmt . var_decls begin_stmt + + error shift, and go to state 17 + Y_NEWLINE shift, and go to state 10 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + ';' shift, and go to state 28 + + Y_BEGIN reduce using rule 25 (var_decls) + + var_decls go to state 29 + var_decl_block go to state 30 + var_decl_line go to state 31 + var_decl_stmt go to state 32 + typedefs go to state 33 + EOST go to state 34 + NL go to state 35 + + +state 9 + + 16 script_body: begin_stmt . @3 s_list opnl end_stmt + + $default reduce using rule 15 (@3) + + @3 go to state 36 + + +state 10 + + 259 NL: Y_NEWLINE . + + $default reduce using rule 259 (NL) + + +state 11 + + 7 block: error NL . + + $default reduce using rule 7 (block) + + +state 12 + + 18 proc_stmt: Y_PROCEDURE @4 . param bparam_list EOST + + Y_IDENT shift, and go to state 37 + + param go to state 38 + + +state 13 + + 76 begin_stmt: Y_BEGIN NL . + + $default reduce using rule 76 (begin_stmt) + + +state 14 + + 2 block: '.' NL . + + $default reduce using rule 2 (block) + + +state 15 + + 0 $accept: block $end . + + $default accept + + +state 16 + + 4 block: block @1 . debug xstmt + + D_D shift, and go to state 39 + D_PEEK shift, and go to state 40 + '~' shift, and go to state 41 + + $default reduce using rule 8 (debug) + + debug go to state 42 + D_XXX go to state 43 + + +state 17 + + 31 var_decl_line: error . NL + + Y_NEWLINE shift, and go to state 10 + + NL go to state 44 + + +state 18 + + 34 typedefs: Y_BOOL . + + $default reduce using rule 34 (typedefs) + + +state 19 + + 42 typedefs: Y_INT . + + $default reduce using rule 42 (typedefs) + + +state 20 + + 36 typedefs: Y_REAL . + + $default reduce using rule 36 (typedefs) + + +state 21 + + 35 typedefs: Y_STRING . + + $default reduce using rule 35 (typedefs) + + +state 22 + + 37 typedefs: Y_FILE . + + $default reduce using rule 37 (typedefs) + + +state 23 + + 43 typedefs: Y_STRUCT . + + $default reduce using rule 43 (typedefs) + + +state 24 + + 38 typedefs: Y_GCUR . + + $default reduce using rule 38 (typedefs) + + +state 25 + + 39 typedefs: Y_IMCUR . + + $default reduce using rule 39 (typedefs) + + +state 26 + + 40 typedefs: Y_UKEY . + + $default reduce using rule 40 (typedefs) + + +state 27 + + 41 typedefs: Y_PSET . + + $default reduce using rule 41 (typedefs) + + +state 28 + + 251 EOST: ';' . + + $default reduce using rule 251 (EOST) + + +state 29 + + 14 script_params: proc_stmt var_decls . begin_stmt + + Y_BEGIN shift, and go to state 3 + + begin_stmt go to state 45 + + +state 30 + + 26 var_decls: var_decl_block . + 28 var_decl_block: var_decl_block . var_decl_line + + error shift, and go to state 17 + Y_NEWLINE shift, and go to state 10 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + ';' shift, and go to state 28 + + Y_BEGIN reduce using rule 26 (var_decls) + + var_decl_line go to state 46 + var_decl_stmt go to state 32 + typedefs go to state 33 + EOST go to state 34 + NL go to state 35 + + +state 31 + + 27 var_decl_block: var_decl_line . + + $default reduce using rule 27 (var_decl_block) + + +state 32 + + 30 var_decl_line: var_decl_stmt . + + $default reduce using rule 30 (var_decl_line) + + +state 33 + + 33 var_decl_stmt: typedefs . @5 var_decl_list EOST + + $default reduce using rule 32 (@5) + + @5 go to state 47 + + +state 34 + + 29 var_decl_line: EOST . + + $default reduce using rule 29 (var_decl_line) + + +state 35 + + 250 EOST: NL . + + $default reduce using rule 250 (EOST) + + +state 36 + + 16 script_body: begin_stmt @3 . s_list opnl end_stmt + + $default reduce using rule 148 (s_list) + + s_list go to state 48 + + +state 37 + + 248 param: Y_IDENT . + + $default reduce using rule 248 (param) + + +state 38 + + 18 proc_stmt: Y_PROCEDURE @4 param . bparam_list EOST + + '(' shift, and go to state 49 + + $default reduce using rule 19 (bparam_list) + + bparam_list go to state 50 + LP go to state 51 + + +state 39 + + 11 D_XXX: D_D . + + $default reduce using rule 11 (D_XXX) + + +state 40 + + 12 D_XXX: D_PEEK . Y_CONSTANT + + Y_CONSTANT shift, and go to state 52 + + +state 41 + + 13 D_XXX: '~' . + + $default reduce using rule 13 (D_XXX) + + +state 42 + + 4 block: block @1 debug . xstmt + + error shift, and go to state 53 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + + Y_OSESC reduce using rule 228 (@33) + Y_IDENT reduce using rule 228 (@33) + Y_WHILE reduce using rule 228 (@33) + Y_IF reduce using rule 228 (@33) + Y_FOR reduce using rule 228 (@33) + Y_BREAK reduce using rule 228 (@33) + Y_NEXT reduce using rule 228 (@33) + Y_SWITCH reduce using rule 228 (@33) + Y_CASE reduce using rule 228 (@33) + Y_DEFAULT reduce using rule 228 (@33) + Y_RETURN reduce using rule 228 (@33) + Y_GOTO reduce using rule 228 (@33) + '=' reduce using rule 228 (@33) + '{' reduce using rule 228 (@33) + ';' reduce using rule 228 (@33) + + var_decl_stmt go to state 54 + typedefs go to state 33 + xstmt go to state 55 + @33 go to state 56 + + +state 43 + + 10 debug: D_XXX . EOST @2 debug + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 57 + NL go to state 35 + + +state 44 + + 31 var_decl_line: error NL . + + $default reduce using rule 31 (var_decl_line) + + +state 45 + + 14 script_params: proc_stmt var_decls begin_stmt . + + $default reduce using rule 14 (script_params) + + +state 46 + + 28 var_decl_block: var_decl_block var_decl_line . + + $default reduce using rule 28 (var_decl_block) + + +state 47 + + 33 var_decl_stmt: typedefs @5 . var_decl_list EOST + + Y_IDENT shift, and go to state 37 + '*' shift, and go to state 58 + + var_decl_list go to state 59 + var_decl_plus go to state 60 + var_decl go to state 61 + var_def go to state 62 + var_name go to state 63 + param go to state 64 + + +state 48 + + 16 script_body: begin_stmt @3 s_list . opnl end_stmt + 149 s_list: s_list . opnl xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 65 + NL go to state 66 + + +state 49 + + 257 LP: '(' . + + $default reduce using rule 257 (LP) + + +state 50 + + 18 proc_stmt: Y_PROCEDURE @4 param bparam_list . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 67 + NL go to state 35 + + +state 51 + + 20 bparam_list: LP . param_list RP + + Y_IDENT shift, and go to state 37 + + $default reduce using rule 21 (param_list) + + param_list go to state 68 + xparam_list go to state 69 + param go to state 70 + + +state 52 + + 12 D_XXX: D_PEEK Y_CONSTANT . + + $default reduce using rule 12 (D_XXX) + + +state 53 + + 231 xstmt: error . NL + + Y_NEWLINE shift, and go to state 10 + + NL go to state 71 + + +state 54 + + 230 xstmt: var_decl_stmt . + + $default reduce using rule 230 (xstmt) + + +state 55 + + 4 block: block @1 debug xstmt . + + $default reduce using rule 4 (block) + + +state 56 + + 229 xstmt: @33 . stmt + + Y_OSESC shift, and go to state 72 + Y_IDENT shift, and go to state 73 + Y_WHILE shift, and go to state 74 + Y_IF shift, and go to state 75 + Y_FOR shift, and go to state 76 + Y_BREAK shift, and go to state 77 + Y_NEXT shift, and go to state 78 + Y_SWITCH shift, and go to state 79 + Y_CASE shift, and go to state 80 + Y_DEFAULT shift, and go to state 81 + Y_RETURN shift, and go to state 82 + Y_GOTO shift, and go to state 83 + '=' shift, and go to state 84 + '{' shift, and go to state 85 + ';' shift, and go to state 86 + + stmt go to state 87 + c_stmt go to state 88 + c_blk go to state 89 + assign go to state 90 + equals go to state 91 + cmdlist go to state 92 + command go to state 93 + immed go to state 94 + inspect go to state 95 + osesc go to state 96 + popstk go to state 97 + if go to state 98 + if_stat go to state 99 + ifelse go to state 100 + while go to state 101 + for go to state 102 + switch go to state 103 + case go to state 104 + default go to state 105 + next go to state 106 + break go to state 107 + return go to state 108 + label_stmt go to state 109 + goto go to state 110 + nullstmt go to state 111 + ref go to state 112 + param go to state 113 + tasknam go to state 114 + + +state 57 + + 10 debug: D_XXX EOST . @2 debug + + $default reduce using rule 9 (@2) + + @2 go to state 115 + + +state 58 + + 55 var_name: '*' . param + + Y_IDENT shift, and go to state 37 + + param go to state 116 + + +state 59 + + 33 var_decl_stmt: typedefs @5 var_decl_list . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 117 + NL go to state 35 + + +state 60 + + 44 var_decl_list: var_decl_plus . + 45 | var_decl_plus . DELIM var_decl_list + + ',' shift, and go to state 118 + + $default reduce using rule 44 (var_decl_list) + + DELIM go to state 119 + + +state 61 + + 46 var_decl_plus: var_decl . + 47 | var_decl . '{' options_list ';' '}' + + '{' shift, and go to state 120 + + $default reduce using rule 46 (var_decl_plus) + + +state 62 + + 48 var_decl: var_def . + 50 | var_def . '=' @6 init_list + + '=' shift, and go to state 121 + + $default reduce using rule 48 (var_decl) + + +state 63 + + 51 var_def: var_name . + 53 | var_name . @7 '[' init_index_list ']' + + '[' reduce using rule 52 (@7) + $default reduce using rule 51 (var_def) + + @7 go to state 122 + + +state 64 + + 54 var_name: param . + + $default reduce using rule 54 (var_name) + + +state 65 + + 16 script_body: begin_stmt @3 s_list opnl . end_stmt + 149 s_list: s_list opnl . xstmt + + error shift, and go to state 53 + Y_END shift, and go to state 123 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + + Y_OSESC reduce using rule 228 (@33) + Y_IDENT reduce using rule 228 (@33) + Y_WHILE reduce using rule 228 (@33) + Y_IF reduce using rule 228 (@33) + Y_FOR reduce using rule 228 (@33) + Y_BREAK reduce using rule 228 (@33) + Y_NEXT reduce using rule 228 (@33) + Y_SWITCH reduce using rule 228 (@33) + Y_CASE reduce using rule 228 (@33) + Y_DEFAULT reduce using rule 228 (@33) + Y_RETURN reduce using rule 228 (@33) + Y_GOTO reduce using rule 228 (@33) + '=' reduce using rule 228 (@33) + '{' reduce using rule 228 (@33) + ';' reduce using rule 228 (@33) + + var_decl_stmt go to state 54 + typedefs go to state 33 + end_stmt go to state 124 + xstmt go to state 125 + @33 go to state 56 + + +state 66 + + 236 opnl: NL . + + $default reduce using rule 236 (opnl) + + +state 67 + + 18 proc_stmt: Y_PROCEDURE @4 param bparam_list EOST . + + $default reduce using rule 18 (proc_stmt) + + +state 68 + + 20 bparam_list: LP param_list . RP + + ')' shift, and go to state 126 + + RP go to state 127 + + +state 69 + + 22 param_list: xparam_list . + 24 xparam_list: xparam_list . DELIM param + + ',' shift, and go to state 118 + + $default reduce using rule 22 (param_list) + + DELIM go to state 128 + + +state 70 + + 23 xparam_list: param . + + $default reduce using rule 23 (xparam_list) + + +state 71 + + 231 xstmt: error NL . + + $default reduce using rule 231 (xstmt) + + +state 72 + + 193 osesc: Y_OSESC . + + $default reduce using rule 193 (osesc) + + +state 73 + + 224 label_stmt: Y_IDENT . ':' opnl @32 xstmt + 248 param: Y_IDENT . + 249 tasknam: Y_IDENT . + + ':' shift, and go to state 129 + + '=' reduce using rule 248 (param) + YOP_AOCAT reduce using rule 248 (param) + YOP_AODIV reduce using rule 248 (param) + YOP_AOMUL reduce using rule 248 (param) + YOP_AOSUB reduce using rule 248 (param) + YOP_AOADD reduce using rule 248 (param) + '[' reduce using rule 248 (param) + $default reduce using rule 249 (tasknam) + + +state 74 + + 202 while: Y_WHILE . LP @23 expr RP @24 opnl xstmt + + '(' shift, and go to state 49 + + LP go to state 130 + + +state 75 + + 197 if_stat: Y_IF . LP expr RP @21 opnl xstmt + + '(' shift, and go to state 49 + + LP go to state 131 + + +state 76 + + 206 for: Y_FOR . LP opnl xassign ';' opnl @25 xexpr ';' opnl @26 xassign RP opnl @27 stmt + + '(' shift, and go to state 49 + + LP go to state 132 + + +state 77 + + 219 break: Y_BREAK . + + $default reduce using rule 219 (break) + + +state 78 + + 218 next: Y_NEXT . + + $default reduce using rule 218 (next) + + +state 79 + + 212 switch: Y_SWITCH . opnl LP opnl expr opnl RP opnl @28 xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 133 + NL go to state 66 + + +state 80 + + 215 case: Y_CASE . @29 const_expr_list ':' opnl @30 xstmt + + $default reduce using rule 213 (@29) + + @29 go to state 134 + + +state 81 + + 217 default: Y_DEFAULT . ':' opnl @31 xstmt + + ':' shift, and go to state 135 + + +state 82 + + 220 return: Y_RETURN . + 221 | Y_RETURN . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + $default reduce using rule 220 (return) + + expr go to state 150 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 83 + + 225 goto: Y_GOTO . Y_IDENT + + Y_IDENT shift, and go to state 157 + + +state 84 + + 154 equals: '=' . + + $default reduce using rule 154 (equals) + + +state 85 + + 147 c_blk: '{' . @13 s_list opnl @14 '}' + + $default reduce using rule 145 (@13) + + @13 go to state 158 + + +state 86 + + 226 nullstmt: ';' . + 227 | ';' . NL + + Y_NEWLINE shift, and go to state 10 + + Y_NEWLINE [reduce using rule 226 (nullstmt)] + $default reduce using rule 226 (nullstmt) + + NL go to state 159 + + +state 87 + + 229 xstmt: @33 stmt . + + $default reduce using rule 229 (xstmt) + + +state 88 + + 123 stmt: c_stmt . + + $default reduce using rule 123 (stmt) + + +state 89 + + 143 c_stmt: c_blk . + 144 | c_blk . NL + + Y_NEWLINE shift, and go to state 10 + + Y_NEWLINE [reduce using rule 143 (c_stmt)] + $default reduce using rule 143 (c_stmt) + + NL go to state 160 + + +state 90 + + 124 stmt: assign . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 161 + NL go to state 35 + + +state 91 + + 190 immed: equals . expr0 + 191 | equals . ref + 194 popstk: equals . + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + $default reduce using rule 194 (popstk) + + expr go to state 162 + expr0 go to state 163 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 164 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 92 + + 125 stmt: cmdlist . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 165 + NL go to state 35 + + +state 93 + + 161 cmdlist: command . @16 cmdpipe + + $default reduce using rule 160 (@16) + + @16 go to state 166 + + +state 94 + + 126 stmt: immed . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 167 + NL go to state 35 + + +state 95 + + 127 stmt: inspect . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 168 + NL go to state 35 + + +state 96 + + 128 stmt: osesc . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 169 + NL go to state 35 + + +state 97 + + 129 stmt: popstk . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 170 + NL go to state 35 + + +state 98 + + 130 stmt: if . + + $default reduce using rule 130 (stmt) + + +state 99 + + 195 if: if_stat . + 199 ifelse: if_stat . Y_ELSE @22 opnl xstmt + + Y_ELSE shift, and go to state 171 + + Y_ELSE [reduce using rule 195 (if)] + $default reduce using rule 195 (if) + + +state 100 + + 131 stmt: ifelse . + + $default reduce using rule 131 (stmt) + + +state 101 + + 132 stmt: while . + + $default reduce using rule 132 (stmt) + + +state 102 + + 133 stmt: for . + + $default reduce using rule 133 (stmt) + + +state 103 + + 134 stmt: switch . + + $default reduce using rule 134 (stmt) + + +state 104 + + 135 stmt: case . + + $default reduce using rule 135 (stmt) + + +state 105 + + 136 stmt: default . + + $default reduce using rule 136 (stmt) + + +state 106 + + 137 stmt: next . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 172 + NL go to state 35 + + +state 107 + + 138 stmt: break . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 173 + NL go to state 35 + + +state 108 + + 140 stmt: return . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 174 + NL go to state 35 + + +state 109 + + 141 stmt: label_stmt . + + $default reduce using rule 141 (stmt) + + +state 110 + + 139 stmt: goto . EOST + + Y_NEWLINE shift, and go to state 10 + ';' shift, and go to state 28 + + EOST go to state 175 + NL go to state 35 + + +state 111 + + 142 stmt: nullstmt . + + $default reduce using rule 142 (stmt) + + +state 112 + + 150 assign: ref . equals expr0 + 151 | ref . equals ref + 153 | ref . @15 assign_oper expr + 192 inspect: ref . equals + + '=' shift, and go to state 84 + + $default reduce using rule 152 (@15) + + @15 go to state 176 + equals go to state 177 + + +state 113 + + 237 ref: param . + 239 | param . @34 '[' index_list ']' + + '[' reduce using rule 238 (@34) + $default reduce using rule 237 (ref) + + @34 go to state 178 + + +state 114 + + 169 command: tasknam . @18 BARG @19 args EARG + + $default reduce using rule 167 (@18) + + @18 go to state 179 + + +state 115 + + 10 debug: D_XXX EOST @2 . debug + + D_D shift, and go to state 39 + D_PEEK shift, and go to state 40 + '~' shift, and go to state 41 + + $default reduce using rule 8 (debug) + + debug go to state 180 + D_XXX go to state 43 + + +state 116 + + 55 var_name: '*' param . + + $default reduce using rule 55 (var_name) + + +state 117 + + 33 var_decl_stmt: typedefs @5 var_decl_list EOST . + + $default reduce using rule 33 (var_decl_stmt) + + +state 118 + + 252 DELIM: ',' . + + $default reduce using rule 252 (DELIM) + + +state 119 + + 45 var_decl_list: var_decl_plus DELIM . var_decl_list + + Y_IDENT shift, and go to state 37 + '*' shift, and go to state 58 + + var_decl_list go to state 181 + var_decl_plus go to state 60 + var_decl go to state 61 + var_def go to state 62 + var_name go to state 63 + param go to state 64 + + +state 120 + + 47 var_decl_plus: var_decl '{' . options_list ';' '}' + + Y_CONSTANT shift, and go to state 182 + Y_IDENT shift, and go to state 183 + '+' shift, and go to state 184 + '-' shift, and go to state 185 + + init_list go to state 186 + init_elem go to state 187 + const go to state 188 + number go to state 189 + sign go to state 190 + options_list go to state 191 + options go to state 192 + option go to state 193 + + +state 121 + + 50 var_decl: var_def '=' . @6 init_list + + $default reduce using rule 49 (@6) + + @6 go to state 194 + + +state 122 + + 53 var_def: var_name @7 . '[' init_index_list ']' + + '[' shift, and go to state 195 + + +state 123 + + 222 end_stmt: Y_END . NL + + Y_NEWLINE shift, and go to state 10 + + NL go to state 196 + + +state 124 + + 16 script_body: begin_stmt @3 s_list opnl end_stmt . + + $default reduce using rule 16 (script_body) + + +state 125 + + 149 s_list: s_list opnl xstmt . + + $default reduce using rule 149 (s_list) + + +state 126 + + 258 RP: ')' . + + $default reduce using rule 258 (RP) + + +state 127 + + 20 bparam_list: LP param_list RP . + + $default reduce using rule 20 (bparam_list) + + +state 128 + + 24 xparam_list: xparam_list DELIM . param + + Y_IDENT shift, and go to state 37 + + param go to state 197 + + +state 129 + + 224 label_stmt: Y_IDENT ':' . opnl @32 xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 198 + NL go to state 66 + + +state 130 + + 202 while: Y_WHILE LP . @23 expr RP @24 opnl xstmt + + $default reduce using rule 200 (@23) + + @23 go to state 199 + + +state 131 + + 197 if_stat: Y_IF LP . expr RP @21 opnl xstmt + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 200 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 132 + + 206 for: Y_FOR LP . opnl xassign ';' opnl @25 xexpr ';' opnl @26 xassign RP opnl @27 stmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 201 + NL go to state 66 + + +state 133 + + 212 switch: Y_SWITCH opnl . LP opnl expr opnl RP opnl @28 xstmt + + '(' shift, and go to state 49 + + LP go to state 202 + + +state 134 + + 215 case: Y_CASE @29 . const_expr_list ':' opnl @30 xstmt + + Y_CONSTANT shift, and go to state 203 + + const_expr_list go to state 204 + const_expr go to state 205 + + +state 135 + + 217 default: Y_DEFAULT ':' . opnl @31 xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 206 + NL go to state 66 + + +state 136 + + 104 expr1: Y_SCAN . LP @8 scanarg RP + + '(' shift, and go to state 49 + + LP go to state 207 + + +state 137 + + 106 expr1: Y_SCANF . LP @9 scanfmt DELIM scanarg RP + + '(' shift, and go to state 49 + + LP go to state 208 + + +state 138 + + 108 expr1: Y_FSCAN . LP @10 scanarg RP + + '(' shift, and go to state 49 + + LP go to state 209 + + +state 139 + + 110 expr1: Y_FSCANF . LP Y_IDENT DELIM @11 scanfmt DELIM scanarg RP + + '(' shift, and go to state 49 + + LP go to state 210 + + +state 140 + + 80 expr0: Y_CONSTANT . + + $default reduce using rule 80 (expr0) + + +state 141 + + 247 intrins: Y_IDENT . + 248 param: Y_IDENT . + + '(' reduce using rule 247 (intrins) + $default reduce using rule 248 (param) + + +state 142 + + 114 intrinsx: Y_INT . + + $default reduce using rule 114 (intrinsx) + + +state 143 + + 115 intrinsx: Y_REAL . + + $default reduce using rule 115 (intrinsx) + + +state 144 + + 81 expr0: Y_GCUR . + + $default reduce using rule 81 (expr0) + + +state 145 + + 82 expr0: Y_IMCUR . + + $default reduce using rule 82 (expr0) + + +state 146 + + 83 expr0: Y_UKEY . + + $default reduce using rule 83 (expr0) + + +state 147 + + 84 expr0: Y_PSET . + + $default reduce using rule 84 (expr0) + + +state 148 + + 102 expr1: '-' . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 211 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 149 + + 101 expr1: YOP_NOT . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 212 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 150 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 221 return: Y_RETURN expr . + + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 221 (return) + + +state 151 + + 77 expr: expr0 . + + $default reduce using rule 77 (expr) + + +state 152 + + 79 expr0: expr1 . + + $default reduce using rule 79 (expr0) + + +state 153 + + 112 expr1: intrinsx . LP @12 intrarg RP + + '(' shift, and go to state 49 + + LP go to state 228 + + +state 154 + + 78 expr: ref . + + $default reduce using rule 78 (expr) + + +state 155 + + 113 intrinsx: intrins . + + $default reduce using rule 113 (intrinsx) + + +state 156 + + 85 expr1: LP . expr RP + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 229 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 157 + + 225 goto: Y_GOTO Y_IDENT . + + $default reduce using rule 225 (goto) + + +state 158 + + 147 c_blk: '{' @13 . s_list opnl @14 '}' + + $default reduce using rule 148 (s_list) + + s_list go to state 230 + + +state 159 + + 227 nullstmt: ';' NL . + + $default reduce using rule 227 (nullstmt) + + +state 160 + + 144 c_stmt: c_blk NL . + + $default reduce using rule 144 (c_stmt) + + +state 161 + + 124 stmt: assign EOST . + + $default reduce using rule 124 (stmt) + + +state 162 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + +state 163 + + 77 expr: expr0 . + 190 immed: equals expr0 . + + Y_NEWLINE reduce using rule 190 (immed) + ';' reduce using rule 190 (immed) + $default reduce using rule 77 (expr) + + +state 164 + + 78 expr: ref . + 191 immed: equals ref . + + Y_NEWLINE reduce using rule 191 (immed) + ';' reduce using rule 191 (immed) + $default reduce using rule 78 (expr) + + +state 165 + + 125 stmt: cmdlist EOST . + + $default reduce using rule 125 (stmt) + + +state 166 + + 161 cmdlist: command @16 . cmdpipe + + $default reduce using rule 162 (cmdpipe) + + cmdpipe go to state 231 + + +state 167 + + 126 stmt: immed EOST . + + $default reduce using rule 126 (stmt) + + +state 168 + + 127 stmt: inspect EOST . + + $default reduce using rule 127 (stmt) + + +state 169 + + 128 stmt: osesc EOST . + + $default reduce using rule 128 (stmt) + + +state 170 + + 129 stmt: popstk EOST . + + $default reduce using rule 129 (stmt) + + +state 171 + + 199 ifelse: if_stat Y_ELSE . @22 opnl xstmt + + $default reduce using rule 198 (@22) + + @22 go to state 232 + + +state 172 + + 137 stmt: next EOST . + + $default reduce using rule 137 (stmt) + + +state 173 + + 138 stmt: break EOST . + + $default reduce using rule 138 (stmt) + + +state 174 + + 140 stmt: return EOST . + + $default reduce using rule 140 (stmt) + + +state 175 + + 139 stmt: goto EOST . + + $default reduce using rule 139 (stmt) + + +state 176 + + 153 assign: ref @15 . assign_oper expr + + YOP_AOCAT shift, and go to state 233 + YOP_AODIV shift, and go to state 234 + YOP_AOMUL shift, and go to state 235 + YOP_AOSUB shift, and go to state 236 + YOP_AOADD shift, and go to state 237 + + assign_oper go to state 238 + + +state 177 + + 150 assign: ref equals . expr0 + 151 | ref equals . ref + 192 inspect: ref equals . + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + $default reduce using rule 192 (inspect) + + expr go to state 162 + expr0 go to state 239 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 240 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 178 + + 239 ref: param @34 . '[' index_list ']' + + '[' shift, and go to state 241 + + +state 179 + + 169 command: tasknam @18 . BARG @19 args EARG + + '(' shift, and go to state 49 + + '(' [reduce using rule 253 (BARG)] + $default reduce using rule 253 (BARG) + + BARG go to state 242 + LP go to state 243 + + +state 180 + + 10 debug: D_XXX EOST @2 debug . + + $default reduce using rule 10 (debug) + + +state 181 + + 45 var_decl_list: var_decl_plus DELIM var_decl_list . + + $default reduce using rule 45 (var_decl_list) + + +state 182 + + 64 init_elem: Y_CONSTANT . LP const RP + 65 const: Y_CONSTANT . + + '(' shift, and go to state 49 + + $default reduce using rule 65 (const) + + LP go to state 244 + + +state 183 + + 75 option: Y_IDENT . '=' const + + '=' shift, and go to state 245 + + +state 184 + + 68 sign: '+' . + + $default reduce using rule 68 (sign) + + +state 185 + + 69 sign: '-' . + + $default reduce using rule 69 (sign) + + +state 186 + + 62 init_list: init_list . DELIM init_elem + 70 options_list: init_list . DELIM options + 71 | init_list . + + ',' shift, and go to state 118 + + $default reduce using rule 71 (options_list) + + DELIM go to state 246 + + +state 187 + + 61 init_list: init_elem . + + $default reduce using rule 61 (init_list) + + +state 188 + + 63 init_elem: const . + + $default reduce using rule 63 (init_elem) + + +state 189 + + 66 const: number . + + $default reduce using rule 66 (const) + + +state 190 + + 67 number: sign . Y_CONSTANT + + Y_CONSTANT shift, and go to state 247 + + +state 191 + + 47 var_decl_plus: var_decl '{' options_list . ';' '}' + + ';' shift, and go to state 248 + + +state 192 + + 72 options_list: options . + 74 options: options . DELIM option + + ',' shift, and go to state 118 + + $default reduce using rule 72 (options_list) + + DELIM go to state 249 + + +state 193 + + 73 options: option . + + $default reduce using rule 73 (options) + + +state 194 + + 50 var_decl: var_def '=' @6 . init_list + + Y_CONSTANT shift, and go to state 182 + '+' shift, and go to state 184 + '-' shift, and go to state 185 + + init_list go to state 250 + init_elem go to state 187 + const go to state 188 + number go to state 189 + sign go to state 190 + + +state 195 + + 53 var_def: var_name @7 '[' . init_index_list ']' + + Y_CONSTANT shift, and go to state 251 + '+' shift, and go to state 184 + '-' shift, and go to state 185 + + $default reduce using rule 56 (init_index_list) + + init_index_list go to state 252 + init_index_range go to state 253 + const go to state 254 + number go to state 189 + sign go to state 190 + + +state 196 + + 222 end_stmt: Y_END NL . + + $default reduce using rule 222 (end_stmt) + + +state 197 + + 24 xparam_list: xparam_list DELIM param . + + $default reduce using rule 24 (xparam_list) + + +state 198 + + 224 label_stmt: Y_IDENT ':' opnl . @32 xstmt + + $default reduce using rule 223 (@32) + + @32 go to state 255 + + +state 199 + + 202 while: Y_WHILE LP @23 . expr RP @24 opnl xstmt + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 256 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 200 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 197 if_stat: Y_IF LP expr . RP @21 opnl xstmt + + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + ')' shift, and go to state 126 + + RP go to state 257 + + +state 201 + + 206 for: Y_FOR LP opnl . xassign ';' opnl @25 xexpr ';' opnl @26 xassign RP opnl @27 stmt + + Y_IDENT shift, and go to state 37 + + $default reduce using rule 208 (xassign) + + assign go to state 258 + xassign go to state 259 + ref go to state 260 + param go to state 113 + + +state 202 + + 212 switch: Y_SWITCH opnl LP . opnl expr opnl RP opnl @28 xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 261 + NL go to state 66 + + +state 203 + + 234 const_expr: Y_CONSTANT . + + $default reduce using rule 234 (const_expr) + + +state 204 + + 215 case: Y_CASE @29 const_expr_list . ':' opnl @30 xstmt + + ':' shift, and go to state 262 + + +state 205 + + 232 const_expr_list: const_expr . + 233 | const_expr . DELIM const_expr_list + + ',' shift, and go to state 118 + + $default reduce using rule 232 (const_expr_list) + + DELIM go to state 263 + + +state 206 + + 217 default: Y_DEFAULT ':' opnl . @31 xstmt + + $default reduce using rule 216 (@31) + + @31 go to state 264 + + +state 207 + + 104 expr1: Y_SCAN LP . @8 scanarg RP + + $default reduce using rule 103 (@8) + + @8 go to state 265 + + +state 208 + + 106 expr1: Y_SCANF LP . @9 scanfmt DELIM scanarg RP + + $default reduce using rule 105 (@9) + + @9 go to state 266 + + +state 209 + + 108 expr1: Y_FSCAN LP . @10 scanarg RP + + $default reduce using rule 107 (@10) + + @10 go to state 267 + + +state 210 + + 110 expr1: Y_FSCANF LP . Y_IDENT DELIM @11 scanfmt DELIM scanarg RP + + Y_IDENT shift, and go to state 268 + + +state 211 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 102 | '-' expr . + + YOP_POW shift, and go to state 227 + + $default reduce using rule 102 (expr1) + + +state 212 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 101 | YOP_NOT expr . + + YOP_POW shift, and go to state 227 + + $default reduce using rule 101 (expr1) + + +state 213 + + 99 expr1: expr YOP_OR . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 269 + NL go to state 66 + + +state 214 + + 100 expr1: expr YOP_AND . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 270 + NL go to state 66 + + +state 215 + + 98 expr1: expr YOP_NE . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 271 + NL go to state 66 + + +state 216 + + 97 expr1: expr YOP_EQ . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 272 + NL go to state 66 + + +state 217 + + 93 expr1: expr '<' . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 273 + NL go to state 66 + + +state 218 + + 94 expr1: expr '>' . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 274 + NL go to state 66 + + +state 219 + + 96 expr1: expr YOP_GE . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 275 + NL go to state 66 + + +state 220 + + 95 expr1: expr YOP_LE . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 276 + NL go to state 66 + + +state 221 + + 92 expr1: expr YOP_CONCAT . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 277 + NL go to state 66 + + +state 222 + + 86 expr1: expr '+' . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 278 + NL go to state 66 + + +state 223 + + 87 expr1: expr '-' . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 279 + NL go to state 66 + + +state 224 + + 88 expr1: expr '*' . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 280 + NL go to state 66 + + +state 225 + + 89 expr1: expr '/' . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 281 + NL go to state 66 + + +state 226 + + 91 expr1: expr '%' . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 282 + NL go to state 66 + + +state 227 + + 90 expr1: expr YOP_POW . opnl expr + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 283 + NL go to state 66 + + +state 228 + + 112 expr1: intrinsx LP . @12 intrarg RP + + $default reduce using rule 111 (@12) + + @12 go to state 284 + + +state 229 + + 85 expr1: LP expr . RP + 86 | expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + ')' shift, and go to state 126 + + RP go to state 285 + + +state 230 + + 147 c_blk: '{' @13 s_list . opnl @14 '}' + 149 s_list: s_list . opnl xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 286 + NL go to state 66 + + +state 231 + + 161 cmdlist: command @16 cmdpipe . + 164 cmdpipe: cmdpipe . pipe @17 command + + Y_ALLPIPE shift, and go to state 287 + '|' shift, and go to state 288 + + $default reduce using rule 161 (cmdlist) + + pipe go to state 289 + + +state 232 + + 199 ifelse: if_stat Y_ELSE @22 . opnl xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 290 + NL go to state 66 + + +state 233 + + 159 assign_oper: YOP_AOCAT . + + $default reduce using rule 159 (assign_oper) + + +state 234 + + 158 assign_oper: YOP_AODIV . + + $default reduce using rule 158 (assign_oper) + + +state 235 + + 157 assign_oper: YOP_AOMUL . + + $default reduce using rule 157 (assign_oper) + + +state 236 + + 156 assign_oper: YOP_AOSUB . + + $default reduce using rule 156 (assign_oper) + + +state 237 + + 155 assign_oper: YOP_AOADD . + + $default reduce using rule 155 (assign_oper) + + +state 238 + + 153 assign: ref @15 assign_oper . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 291 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 239 + + 77 expr: expr0 . + 150 assign: ref equals expr0 . + + Y_NEWLINE reduce using rule 150 (assign) + ';' reduce using rule 150 (assign) + ')' reduce using rule 150 (assign) + $default reduce using rule 77 (expr) + + +state 240 + + 78 expr: ref . + 151 assign: ref equals ref . + + Y_NEWLINE reduce using rule 151 (assign) + ';' reduce using rule 151 (assign) + ')' reduce using rule 151 (assign) + $default reduce using rule 78 (expr) + + +state 241 + + 239 ref: param @34 '[' . index_list ']' + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 292 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + '*' shift, and go to state 293 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 162 + expr0 go to state 151 + expr1 go to state 294 + intrinsx go to state 153 + ref go to state 295 + index_list go to state 296 + index go to state 297 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 242 + + 169 command: tasknam @18 BARG . @19 args EARG + + $default reduce using rule 168 (@19) + + @19 go to state 298 + + +state 243 + + 254 BARG: LP . + + $default reduce using rule 254 (BARG) + + +state 244 + + 64 init_elem: Y_CONSTANT LP . const RP + + Y_CONSTANT shift, and go to state 251 + '+' shift, and go to state 184 + '-' shift, and go to state 185 + + const go to state 299 + number go to state 189 + sign go to state 190 + + +state 245 + + 75 option: Y_IDENT '=' . const + + Y_CONSTANT shift, and go to state 251 + '+' shift, and go to state 184 + '-' shift, and go to state 185 + + const go to state 300 + number go to state 189 + sign go to state 190 + + +state 246 + + 62 init_list: init_list DELIM . init_elem + 70 options_list: init_list DELIM . options + + Y_CONSTANT shift, and go to state 182 + Y_IDENT shift, and go to state 183 + '+' shift, and go to state 184 + '-' shift, and go to state 185 + + init_elem go to state 301 + const go to state 188 + number go to state 189 + sign go to state 190 + options go to state 302 + option go to state 193 + + +state 247 + + 67 number: sign Y_CONSTANT . + + $default reduce using rule 67 (number) + + +state 248 + + 47 var_decl_plus: var_decl '{' options_list ';' . '}' + + '}' shift, and go to state 303 + + +state 249 + + 74 options: options DELIM . option + + Y_IDENT shift, and go to state 183 + + option go to state 304 + + +state 250 + + 50 var_decl: var_def '=' @6 init_list . + 62 init_list: init_list . DELIM init_elem + + ',' shift, and go to state 118 + + ',' [reduce using rule 50 (var_decl)] + $default reduce using rule 50 (var_decl) + + DELIM go to state 305 + + +state 251 + + 65 const: Y_CONSTANT . + + $default reduce using rule 65 (const) + + +state 252 + + 53 var_def: var_name @7 '[' init_index_list . ']' + 58 init_index_list: init_index_list . DELIM init_index_range + + ']' shift, and go to state 306 + ',' shift, and go to state 118 + + DELIM go to state 307 + + +state 253 + + 57 init_index_list: init_index_range . + + $default reduce using rule 57 (init_index_list) + + +state 254 + + 59 init_index_range: const . + 60 | const . ':' const + + ':' shift, and go to state 308 + + $default reduce using rule 59 (init_index_range) + + +state 255 + + 224 label_stmt: Y_IDENT ':' opnl @32 . xstmt + + error shift, and go to state 53 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + + Y_OSESC reduce using rule 228 (@33) + Y_IDENT reduce using rule 228 (@33) + Y_WHILE reduce using rule 228 (@33) + Y_IF reduce using rule 228 (@33) + Y_FOR reduce using rule 228 (@33) + Y_BREAK reduce using rule 228 (@33) + Y_NEXT reduce using rule 228 (@33) + Y_SWITCH reduce using rule 228 (@33) + Y_CASE reduce using rule 228 (@33) + Y_DEFAULT reduce using rule 228 (@33) + Y_RETURN reduce using rule 228 (@33) + Y_GOTO reduce using rule 228 (@33) + '=' reduce using rule 228 (@33) + '{' reduce using rule 228 (@33) + ';' reduce using rule 228 (@33) + + var_decl_stmt go to state 54 + typedefs go to state 33 + xstmt go to state 309 + @33 go to state 56 + + +state 256 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 202 while: Y_WHILE LP @23 expr . RP @24 opnl xstmt + + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + ')' shift, and go to state 126 + + RP go to state 310 + + +state 257 + + 197 if_stat: Y_IF LP expr RP . @21 opnl xstmt + + $default reduce using rule 196 (@21) + + @21 go to state 311 + + +state 258 + + 207 xassign: assign . + + $default reduce using rule 207 (xassign) + + +state 259 + + 206 for: Y_FOR LP opnl xassign . ';' opnl @25 xexpr ';' opnl @26 xassign RP opnl @27 stmt + + ';' shift, and go to state 312 + + +state 260 + + 150 assign: ref . equals expr0 + 151 | ref . equals ref + 153 | ref . @15 assign_oper expr + + '=' shift, and go to state 84 + + $default reduce using rule 152 (@15) + + @15 go to state 176 + equals go to state 313 + + +state 261 + + 212 switch: Y_SWITCH opnl LP opnl . expr opnl RP opnl @28 xstmt + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 314 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 262 + + 215 case: Y_CASE @29 const_expr_list ':' . opnl @30 xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 315 + NL go to state 66 + + +state 263 + + 233 const_expr_list: const_expr DELIM . const_expr_list + + Y_CONSTANT shift, and go to state 203 + + const_expr_list go to state 316 + const_expr go to state 205 + + +state 264 + + 217 default: Y_DEFAULT ':' opnl @31 . xstmt + + error shift, and go to state 53 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + + Y_OSESC reduce using rule 228 (@33) + Y_IDENT reduce using rule 228 (@33) + Y_WHILE reduce using rule 228 (@33) + Y_IF reduce using rule 228 (@33) + Y_FOR reduce using rule 228 (@33) + Y_BREAK reduce using rule 228 (@33) + Y_NEXT reduce using rule 228 (@33) + Y_SWITCH reduce using rule 228 (@33) + Y_CASE reduce using rule 228 (@33) + Y_DEFAULT reduce using rule 228 (@33) + Y_RETURN reduce using rule 228 (@33) + Y_GOTO reduce using rule 228 (@33) + '=' reduce using rule 228 (@33) + '{' reduce using rule 228 (@33) + ';' reduce using rule 228 (@33) + + var_decl_stmt go to state 54 + typedefs go to state 33 + xstmt go to state 317 + @33 go to state 56 + + +state 265 + + 104 expr1: Y_SCAN LP @8 . scanarg RP + + Y_IDENT shift, and go to state 318 + + $default reduce using rule 117 (scanarg) + + scanarg go to state 319 + + +state 266 + + 106 expr1: Y_SCANF LP @9 . scanfmt DELIM scanarg RP + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 320 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + scanfmt go to state 321 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 267 + + 108 expr1: Y_FSCAN LP @10 . scanarg RP + + Y_IDENT shift, and go to state 318 + + $default reduce using rule 117 (scanarg) + + scanarg go to state 322 + + +state 268 + + 110 expr1: Y_FSCANF LP Y_IDENT . DELIM @11 scanfmt DELIM scanarg RP + + ',' shift, and go to state 118 + + DELIM go to state 323 + + +state 269 + + 99 expr1: expr YOP_OR opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 324 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 270 + + 100 expr1: expr YOP_AND opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 325 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 271 + + 98 expr1: expr YOP_NE opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 326 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 272 + + 97 expr1: expr YOP_EQ opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 327 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 273 + + 93 expr1: expr '<' opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 328 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 274 + + 94 expr1: expr '>' opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 329 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 275 + + 96 expr1: expr YOP_GE opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 330 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 276 + + 95 expr1: expr YOP_LE opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 331 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 277 + + 92 expr1: expr YOP_CONCAT opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 332 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 278 + + 86 expr1: expr '+' opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 333 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 279 + + 87 expr1: expr '-' opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 334 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 280 + + 88 expr1: expr '*' opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 335 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 281 + + 89 expr1: expr '/' opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 336 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 282 + + 91 expr1: expr '%' opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 337 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 283 + + 90 expr1: expr YOP_POW opnl . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 338 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 284 + + 112 expr1: intrinsx LP @12 . intrarg RP + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + $default reduce using rule 120 (intrarg) + + expr go to state 339 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + intrarg go to state 340 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 285 + + 85 expr1: LP expr RP . + + $default reduce using rule 85 (expr1) + + +state 286 + + 147 c_blk: '{' @13 s_list opnl . @14 '}' + 149 s_list: s_list opnl . xstmt + + error shift, and go to state 53 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + + Y_OSESC reduce using rule 228 (@33) + Y_IDENT reduce using rule 228 (@33) + Y_WHILE reduce using rule 228 (@33) + Y_IF reduce using rule 228 (@33) + Y_FOR reduce using rule 228 (@33) + Y_BREAK reduce using rule 228 (@33) + Y_NEXT reduce using rule 228 (@33) + Y_SWITCH reduce using rule 228 (@33) + Y_CASE reduce using rule 228 (@33) + Y_DEFAULT reduce using rule 228 (@33) + Y_RETURN reduce using rule 228 (@33) + Y_GOTO reduce using rule 228 (@33) + '=' reduce using rule 228 (@33) + '{' reduce using rule 228 (@33) + ';' reduce using rule 228 (@33) + '}' reduce using rule 146 (@14) + + var_decl_stmt go to state 54 + typedefs go to state 33 + @14 go to state 341 + xstmt go to state 125 + @33 go to state 56 + + +state 287 + + 166 pipe: Y_ALLPIPE . opnl + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 342 + NL go to state 66 + + +state 288 + + 165 pipe: '|' . opnl + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 343 + NL go to state 66 + + +state 289 + + 164 cmdpipe: cmdpipe pipe . @17 command + + $default reduce using rule 163 (@17) + + @17 go to state 344 + + +state 290 + + 199 ifelse: if_stat Y_ELSE @22 opnl . xstmt + + error shift, and go to state 53 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + + Y_OSESC reduce using rule 228 (@33) + Y_IDENT reduce using rule 228 (@33) + Y_WHILE reduce using rule 228 (@33) + Y_IF reduce using rule 228 (@33) + Y_FOR reduce using rule 228 (@33) + Y_BREAK reduce using rule 228 (@33) + Y_NEXT reduce using rule 228 (@33) + Y_SWITCH reduce using rule 228 (@33) + Y_CASE reduce using rule 228 (@33) + Y_DEFAULT reduce using rule 228 (@33) + Y_RETURN reduce using rule 228 (@33) + Y_GOTO reduce using rule 228 (@33) + '=' reduce using rule 228 (@33) + '{' reduce using rule 228 (@33) + ';' reduce using rule 228 (@33) + + var_decl_stmt go to state 54 + typedefs go to state 33 + xstmt go to state 345 + @33 go to state 56 + + +state 291 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 153 assign: ref @15 assign_oper expr . + + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 153 (assign) + + +state 292 + + 80 expr0: Y_CONSTANT . + 246 index: Y_CONSTANT . + + ']' reduce using rule 246 (index) + ',' reduce using rule 246 (index) + $default reduce using rule 80 (expr0) + + +state 293 + + 245 index: '*' . + + $default reduce using rule 245 (index) + + +state 294 + + 79 expr0: expr1 . + 243 index: expr1 . + + ']' reduce using rule 243 (index) + ',' reduce using rule 243 (index) + $default reduce using rule 79 (expr0) + + +state 295 + + 78 expr: ref . + 244 index: ref . + + ']' reduce using rule 244 (index) + ',' reduce using rule 244 (index) + $default reduce using rule 78 (expr) + + +state 296 + + 239 ref: param @34 '[' index_list . ']' + + ']' shift, and go to state 346 + + +state 297 + + 240 index_list: index . + 242 | index . @35 DELIM index_list + + ',' reduce using rule 241 (@35) + $default reduce using rule 240 (index_list) + + @35 go to state 347 + + +state 298 + + 169 command: tasknam @18 BARG @19 . args EARG + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_APPEND shift, and go to state 348 + Y_ALLAPPEND shift, and go to state 349 + Y_ALLREDIR shift, and go to state 350 + Y_GSREDIR shift, and go to state 351 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '<' shift, and go to state 352 + '>' shift, and go to state 353 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + ',' shift, and go to state 118 + '(' shift, and go to state 49 + + ',' [reduce using rule 175 (arg)] + $default reduce using rule 175 (arg) + + expr go to state 162 + expr0 go to state 354 + expr1 go to state 152 + intrinsx go to state 153 + args go to state 355 + arglist go to state 356 + arg go to state 357 + ref go to state 358 + intrins go to state 155 + param go to state 359 + DELIM go to state 360 + LP go to state 156 + + +state 299 + + 64 init_elem: Y_CONSTANT LP const . RP + + ')' shift, and go to state 126 + + RP go to state 361 + + +state 300 + + 75 option: Y_IDENT '=' const . + + $default reduce using rule 75 (option) + + +state 301 + + 62 init_list: init_list DELIM init_elem . + + $default reduce using rule 62 (init_list) + + +state 302 + + 70 options_list: init_list DELIM options . + 74 options: options . DELIM option + + ',' shift, and go to state 118 + + $default reduce using rule 70 (options_list) + + DELIM go to state 249 + + +state 303 + + 47 var_decl_plus: var_decl '{' options_list ';' '}' . + + $default reduce using rule 47 (var_decl_plus) + + +state 304 + + 74 options: options DELIM option . + + $default reduce using rule 74 (options) + + +state 305 + + 62 init_list: init_list DELIM . init_elem + + Y_CONSTANT shift, and go to state 182 + '+' shift, and go to state 184 + '-' shift, and go to state 185 + + init_elem go to state 301 + const go to state 188 + number go to state 189 + sign go to state 190 + + +state 306 + + 53 var_def: var_name @7 '[' init_index_list ']' . + + $default reduce using rule 53 (var_def) + + +state 307 + + 58 init_index_list: init_index_list DELIM . init_index_range + + Y_CONSTANT shift, and go to state 251 + '+' shift, and go to state 184 + '-' shift, and go to state 185 + + init_index_range go to state 362 + const go to state 254 + number go to state 189 + sign go to state 190 + + +state 308 + + 60 init_index_range: const ':' . const + + Y_CONSTANT shift, and go to state 251 + '+' shift, and go to state 184 + '-' shift, and go to state 185 + + const go to state 363 + number go to state 189 + sign go to state 190 + + +state 309 + + 224 label_stmt: Y_IDENT ':' opnl @32 xstmt . + + $default reduce using rule 224 (label_stmt) + + +state 310 + + 202 while: Y_WHILE LP @23 expr RP . @24 opnl xstmt + + $default reduce using rule 201 (@24) + + @24 go to state 364 + + +state 311 + + 197 if_stat: Y_IF LP expr RP @21 . opnl xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 365 + NL go to state 66 + + +state 312 + + 206 for: Y_FOR LP opnl xassign ';' . opnl @25 xexpr ';' opnl @26 xassign RP opnl @27 stmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 366 + NL go to state 66 + + +state 313 + + 150 assign: ref equals . expr0 + 151 | ref equals . ref + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 162 + expr0 go to state 239 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 240 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 314 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 212 switch: Y_SWITCH opnl LP opnl expr . opnl RP opnl @28 xstmt + + Y_NEWLINE shift, and go to state 10 + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 235 (opnl) + + opnl go to state 367 + NL go to state 66 + + +state 315 + + 215 case: Y_CASE @29 const_expr_list ':' opnl . @30 xstmt + + $default reduce using rule 214 (@30) + + @30 go to state 368 + + +state 316 + + 233 const_expr_list: const_expr DELIM const_expr_list . + + $default reduce using rule 233 (const_expr_list) + + +state 317 + + 217 default: Y_DEFAULT ':' opnl @31 xstmt . + + $default reduce using rule 217 (default) + + +state 318 + + 118 scanarg: Y_IDENT . + 119 | Y_IDENT . DELIM scanarg + + ',' shift, and go to state 118 + + $default reduce using rule 118 (scanarg) + + DELIM go to state 369 + + +state 319 + + 104 expr1: Y_SCAN LP @8 scanarg . RP + + ')' shift, and go to state 126 + + RP go to state 370 + + +state 320 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 116 scanfmt: expr . + + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 116 (scanfmt) + + +state 321 + + 106 expr1: Y_SCANF LP @9 scanfmt . DELIM scanarg RP + + ',' shift, and go to state 118 + + DELIM go to state 371 + + +state 322 + + 108 expr1: Y_FSCAN LP @10 scanarg . RP + + ')' shift, and go to state 126 + + RP go to state 372 + + +state 323 + + 110 expr1: Y_FSCANF LP Y_IDENT DELIM . @11 scanfmt DELIM scanarg RP + + $default reduce using rule 109 (@11) + + @11 go to state 373 + + +state 324 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 99 | expr YOP_OR opnl expr . + 100 | expr . YOP_AND opnl expr + + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 99 (expr1) + + +state 325 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 100 | expr YOP_AND opnl expr . + + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 100 (expr1) + + +state 326 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 98 | expr YOP_NE opnl expr . + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 98 (expr1) + + +state 327 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 97 | expr YOP_EQ opnl expr . + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 97 (expr1) + + +state 328 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 93 | expr '<' opnl expr . + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 93 (expr1) + + +state 329 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 94 | expr '>' opnl expr . + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 94 (expr1) + + +state 330 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 96 | expr YOP_GE opnl expr . + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 96 (expr1) + + +state 331 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 95 | expr YOP_LE opnl expr . + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 95 (expr1) + + +state 332 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 92 | expr YOP_CONCAT opnl expr . + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 92 (expr1) + + +state 333 + + 86 expr1: expr . '+' opnl expr + 86 | expr '+' opnl expr . + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 86 (expr1) + + +state 334 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 87 | expr '-' opnl expr . + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 87 (expr1) + + +state 335 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 88 | expr '*' opnl expr . + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + YOP_POW shift, and go to state 227 + + $default reduce using rule 88 (expr1) + + +state 336 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 89 | expr '/' opnl expr . + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + YOP_POW shift, and go to state 227 + + $default reduce using rule 89 (expr1) + + +state 337 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 91 | expr '%' opnl expr . + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + YOP_POW shift, and go to state 227 + + $default reduce using rule 91 (expr1) + + +state 338 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 90 | expr YOP_POW opnl expr . + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + + $default reduce using rule 90 (expr1) + + +state 339 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 121 intrarg: expr . + + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 121 (intrarg) + + +state 340 + + 112 expr1: intrinsx LP @12 intrarg . RP + 122 intrarg: intrarg . DELIM expr + + ',' shift, and go to state 118 + ')' shift, and go to state 126 + + DELIM go to state 374 + RP go to state 375 + + +state 341 + + 147 c_blk: '{' @13 s_list opnl @14 . '}' + + '}' shift, and go to state 376 + + +state 342 + + 166 pipe: Y_ALLPIPE opnl . + + $default reduce using rule 166 (pipe) + + +state 343 + + 165 pipe: '|' opnl . + + $default reduce using rule 165 (pipe) + + +state 344 + + 164 cmdpipe: cmdpipe pipe @17 . command + + Y_IDENT shift, and go to state 377 + + command go to state 378 + tasknam go to state 114 + + +state 345 + + 199 ifelse: if_stat Y_ELSE @22 opnl xstmt . + + $default reduce using rule 199 (ifelse) + + +state 346 + + 239 ref: param @34 '[' index_list ']' . + + $default reduce using rule 239 (ref) + + +state 347 + + 242 index_list: index @35 . DELIM index_list + + ',' shift, and go to state 118 + + DELIM go to state 379 + + +state 348 + + 185 arg: Y_APPEND . file + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 162 + expr0 go to state 380 + expr1 go to state 152 + intrinsx go to state 153 + file go to state 381 + ref go to state 154 + intrins go to state 155 + param go to state 382 + LP go to state 156 + + +state 349 + + 186 arg: Y_ALLAPPEND . file + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 162 + expr0 go to state 380 + expr1 go to state 152 + intrinsx go to state 153 + file go to state 383 + ref go to state 154 + intrins go to state 155 + param go to state 382 + LP go to state 156 + + +state 350 + + 184 arg: Y_ALLREDIR . file + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 162 + expr0 go to state 380 + expr1 go to state 152 + intrinsx go to state 153 + file go to state 384 + ref go to state 154 + intrins go to state 155 + param go to state 382 + LP go to state 156 + + +state 351 + + 187 arg: Y_GSREDIR . file + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 162 + expr0 go to state 380 + expr1 go to state 152 + intrinsx go to state 153 + file go to state 385 + ref go to state 154 + intrins go to state 155 + param go to state 382 + LP go to state 156 + + +state 352 + + 182 arg: '<' . file + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 162 + expr0 go to state 380 + expr1 go to state 152 + intrinsx go to state 153 + file go to state 386 + ref go to state 154 + intrins go to state 155 + param go to state 382 + LP go to state 156 + + +state 353 + + 183 arg: '>' . file + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 162 + expr0 go to state 380 + expr1 go to state 152 + intrinsx go to state 153 + file go to state 387 + ref go to state 154 + intrins go to state 155 + param go to state 382 + LP go to state 156 + + +state 354 + + 77 expr: expr0 . + 176 arg: expr0 . + + Y_ALLPIPE reduce using rule 176 (arg) + Y_NEWLINE reduce using rule 176 (arg) + ';' reduce using rule 176 (arg) + '|' reduce using rule 176 (arg) + ',' reduce using rule 176 (arg) + ')' reduce using rule 176 (arg) + $default reduce using rule 77 (expr) + + +state 355 + + 169 command: tasknam @18 BARG @19 args . EARG + + ')' shift, and go to state 126 + + $default reduce using rule 255 (EARG) + + EARG go to state 388 + RP go to state 389 + + +state 356 + + 172 args: arglist . + 174 arglist: arglist . DELIM arg + + ',' shift, and go to state 118 + + $default reduce using rule 172 (args) + + DELIM go to state 390 + + +state 357 + + 173 arglist: arg . + + $default reduce using rule 173 (arglist) + + +state 358 + + 78 expr: ref . + 177 arg: ref . + 178 | ref . '=' expr0 + 179 | ref . '=' ref + + '=' shift, and go to state 391 + + Y_ALLPIPE reduce using rule 177 (arg) + Y_NEWLINE reduce using rule 177 (arg) + ';' reduce using rule 177 (arg) + '|' reduce using rule 177 (arg) + ',' reduce using rule 177 (arg) + ')' reduce using rule 177 (arg) + $default reduce using rule 78 (expr) + + +state 359 + + 180 arg: param . '+' + 181 | param . '-' + 237 ref: param . + 239 | param . @34 '[' index_list ']' + + '+' shift, and go to state 392 + '-' shift, and go to state 393 + + '+' [reduce using rule 237 (ref)] + '-' [reduce using rule 237 (ref)] + '[' reduce using rule 238 (@34) + $default reduce using rule 237 (ref) + + @34 go to state 178 + + +state 360 + + 171 args: DELIM . @20 arglist + + $default reduce using rule 170 (@20) + + @20 go to state 394 + + +state 361 + + 64 init_elem: Y_CONSTANT LP const RP . + + $default reduce using rule 64 (init_elem) + + +state 362 + + 58 init_index_list: init_index_list DELIM init_index_range . + + $default reduce using rule 58 (init_index_list) + + +state 363 + + 60 init_index_range: const ':' const . + + $default reduce using rule 60 (init_index_range) + + +state 364 + + 202 while: Y_WHILE LP @23 expr RP @24 . opnl xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 395 + NL go to state 66 + + +state 365 + + 197 if_stat: Y_IF LP expr RP @21 opnl . xstmt + + error shift, and go to state 53 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + + Y_OSESC reduce using rule 228 (@33) + Y_IDENT reduce using rule 228 (@33) + Y_WHILE reduce using rule 228 (@33) + Y_IF reduce using rule 228 (@33) + Y_FOR reduce using rule 228 (@33) + Y_BREAK reduce using rule 228 (@33) + Y_NEXT reduce using rule 228 (@33) + Y_SWITCH reduce using rule 228 (@33) + Y_CASE reduce using rule 228 (@33) + Y_DEFAULT reduce using rule 228 (@33) + Y_RETURN reduce using rule 228 (@33) + Y_GOTO reduce using rule 228 (@33) + '=' reduce using rule 228 (@33) + '{' reduce using rule 228 (@33) + ';' reduce using rule 228 (@33) + + var_decl_stmt go to state 54 + typedefs go to state 33 + xstmt go to state 396 + @33 go to state 56 + + +state 366 + + 206 for: Y_FOR LP opnl xassign ';' opnl . @25 xexpr ';' opnl @26 xassign RP opnl @27 stmt + + $default reduce using rule 203 (@25) + + @25 go to state 397 + + +state 367 + + 212 switch: Y_SWITCH opnl LP opnl expr opnl . RP opnl @28 xstmt + + ')' shift, and go to state 126 + + RP go to state 398 + + +state 368 + + 215 case: Y_CASE @29 const_expr_list ':' opnl @30 . xstmt + + error shift, and go to state 53 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + + Y_OSESC reduce using rule 228 (@33) + Y_IDENT reduce using rule 228 (@33) + Y_WHILE reduce using rule 228 (@33) + Y_IF reduce using rule 228 (@33) + Y_FOR reduce using rule 228 (@33) + Y_BREAK reduce using rule 228 (@33) + Y_NEXT reduce using rule 228 (@33) + Y_SWITCH reduce using rule 228 (@33) + Y_CASE reduce using rule 228 (@33) + Y_DEFAULT reduce using rule 228 (@33) + Y_RETURN reduce using rule 228 (@33) + Y_GOTO reduce using rule 228 (@33) + '=' reduce using rule 228 (@33) + '{' reduce using rule 228 (@33) + ';' reduce using rule 228 (@33) + + var_decl_stmt go to state 54 + typedefs go to state 33 + xstmt go to state 399 + @33 go to state 56 + + +state 369 + + 119 scanarg: Y_IDENT DELIM . scanarg + + Y_IDENT shift, and go to state 318 + + $default reduce using rule 117 (scanarg) + + scanarg go to state 400 + + +state 370 + + 104 expr1: Y_SCAN LP @8 scanarg RP . + + $default reduce using rule 104 (expr1) + + +state 371 + + 106 expr1: Y_SCANF LP @9 scanfmt DELIM . scanarg RP + + Y_IDENT shift, and go to state 318 + + $default reduce using rule 117 (scanarg) + + scanarg go to state 401 + + +state 372 + + 108 expr1: Y_FSCAN LP @10 scanarg RP . + + $default reduce using rule 108 (expr1) + + +state 373 + + 110 expr1: Y_FSCANF LP Y_IDENT DELIM @11 . scanfmt DELIM scanarg RP + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 320 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + scanfmt go to state 402 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 374 + + 122 intrarg: intrarg DELIM . expr + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 403 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 375 + + 112 expr1: intrinsx LP @12 intrarg RP . + + $default reduce using rule 112 (expr1) + + +state 376 + + 147 c_blk: '{' @13 s_list opnl @14 '}' . + + $default reduce using rule 147 (c_blk) + + +state 377 + + 249 tasknam: Y_IDENT . + + $default reduce using rule 249 (tasknam) + + +state 378 + + 164 cmdpipe: cmdpipe pipe @17 command . + + $default reduce using rule 164 (cmdpipe) + + +state 379 + + 242 index_list: index @35 DELIM . index_list + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 292 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + '*' shift, and go to state 293 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 162 + expr0 go to state 151 + expr1 go to state 294 + intrinsx go to state 153 + ref go to state 295 + index_list go to state 404 + index go to state 297 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 380 + + 77 expr: expr0 . + 188 file: expr0 . + + Y_ALLPIPE reduce using rule 188 (file) + Y_NEWLINE reduce using rule 188 (file) + ';' reduce using rule 188 (file) + '|' reduce using rule 188 (file) + ',' reduce using rule 188 (file) + ')' reduce using rule 188 (file) + $default reduce using rule 77 (expr) + + +state 381 + + 185 arg: Y_APPEND file . + + $default reduce using rule 185 (arg) + + +state 382 + + 189 file: param . + 237 ref: param . + 239 | param . @34 '[' index_list ']' + + Y_ALLPIPE reduce using rule 189 (file) + Y_NEWLINE reduce using rule 189 (file) + ';' reduce using rule 189 (file) + '[' reduce using rule 238 (@34) + '|' reduce using rule 189 (file) + ',' reduce using rule 189 (file) + ')' reduce using rule 189 (file) + $default reduce using rule 237 (ref) + + @34 go to state 178 + + +state 383 + + 186 arg: Y_ALLAPPEND file . + + $default reduce using rule 186 (arg) + + +state 384 + + 184 arg: Y_ALLREDIR file . + + $default reduce using rule 184 (arg) + + +state 385 + + 187 arg: Y_GSREDIR file . + + $default reduce using rule 187 (arg) + + +state 386 + + 182 arg: '<' file . + + $default reduce using rule 182 (arg) + + +state 387 + + 183 arg: '>' file . + + $default reduce using rule 183 (arg) + + +state 388 + + 169 command: tasknam @18 BARG @19 args EARG . + + $default reduce using rule 169 (command) + + +state 389 + + 256 EARG: RP . + + $default reduce using rule 256 (EARG) + + +state 390 + + 174 arglist: arglist DELIM . arg + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_APPEND shift, and go to state 348 + Y_ALLAPPEND shift, and go to state 349 + Y_ALLREDIR shift, and go to state 350 + Y_GSREDIR shift, and go to state 351 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '<' shift, and go to state 352 + '>' shift, and go to state 353 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + $default reduce using rule 175 (arg) + + expr go to state 162 + expr0 go to state 354 + expr1 go to state 152 + intrinsx go to state 153 + arg go to state 405 + ref go to state 358 + intrins go to state 155 + param go to state 359 + LP go to state 156 + + +state 391 + + 178 arg: ref '=' . expr0 + 179 | ref '=' . ref + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + expr go to state 162 + expr0 go to state 406 + expr1 go to state 152 + intrinsx go to state 153 + ref go to state 407 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 392 + + 180 arg: param '+' . + + $default reduce using rule 180 (arg) + + +state 393 + + 181 arg: param '-' . + + $default reduce using rule 181 (arg) + + +state 394 + + 171 args: DELIM @20 . arglist + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_APPEND shift, and go to state 348 + Y_ALLAPPEND shift, and go to state 349 + Y_ALLREDIR shift, and go to state 350 + Y_GSREDIR shift, and go to state 351 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '<' shift, and go to state 352 + '>' shift, and go to state 353 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + $default reduce using rule 175 (arg) + + expr go to state 162 + expr0 go to state 354 + expr1 go to state 152 + intrinsx go to state 153 + arglist go to state 408 + arg go to state 357 + ref go to state 358 + intrins go to state 155 + param go to state 359 + LP go to state 156 + + +state 395 + + 202 while: Y_WHILE LP @23 expr RP @24 opnl . xstmt + + error shift, and go to state 53 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + + Y_OSESC reduce using rule 228 (@33) + Y_IDENT reduce using rule 228 (@33) + Y_WHILE reduce using rule 228 (@33) + Y_IF reduce using rule 228 (@33) + Y_FOR reduce using rule 228 (@33) + Y_BREAK reduce using rule 228 (@33) + Y_NEXT reduce using rule 228 (@33) + Y_SWITCH reduce using rule 228 (@33) + Y_CASE reduce using rule 228 (@33) + Y_DEFAULT reduce using rule 228 (@33) + Y_RETURN reduce using rule 228 (@33) + Y_GOTO reduce using rule 228 (@33) + '=' reduce using rule 228 (@33) + '{' reduce using rule 228 (@33) + ';' reduce using rule 228 (@33) + + var_decl_stmt go to state 54 + typedefs go to state 33 + xstmt go to state 409 + @33 go to state 56 + + +state 396 + + 197 if_stat: Y_IF LP expr RP @21 opnl xstmt . + + $default reduce using rule 197 (if_stat) + + +state 397 + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 . xexpr ';' opnl @26 xassign RP opnl @27 stmt + + Y_SCAN shift, and go to state 136 + Y_SCANF shift, and go to state 137 + Y_FSCAN shift, and go to state 138 + Y_FSCANF shift, and go to state 139 + Y_CONSTANT shift, and go to state 140 + Y_IDENT shift, and go to state 141 + Y_INT shift, and go to state 142 + Y_REAL shift, and go to state 143 + Y_GCUR shift, and go to state 144 + Y_IMCUR shift, and go to state 145 + Y_UKEY shift, and go to state 146 + Y_PSET shift, and go to state 147 + '-' shift, and go to state 148 + YOP_NOT shift, and go to state 149 + '(' shift, and go to state 49 + + $default reduce using rule 210 (xexpr) + + expr go to state 410 + expr0 go to state 151 + expr1 go to state 152 + intrinsx go to state 153 + xexpr go to state 411 + ref go to state 154 + intrins go to state 155 + param go to state 113 + LP go to state 156 + + +state 398 + + 212 switch: Y_SWITCH opnl LP opnl expr opnl RP . opnl @28 xstmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 412 + NL go to state 66 + + +state 399 + + 215 case: Y_CASE @29 const_expr_list ':' opnl @30 xstmt . + + $default reduce using rule 215 (case) + + +state 400 + + 119 scanarg: Y_IDENT DELIM scanarg . + + $default reduce using rule 119 (scanarg) + + +state 401 + + 106 expr1: Y_SCANF LP @9 scanfmt DELIM scanarg . RP + + ')' shift, and go to state 126 + + RP go to state 413 + + +state 402 + + 110 expr1: Y_FSCANF LP Y_IDENT DELIM @11 scanfmt . DELIM scanarg RP + + ',' shift, and go to state 118 + + DELIM go to state 414 + + +state 403 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 122 intrarg: intrarg DELIM expr . + + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 122 (intrarg) + + +state 404 + + 242 index_list: index @35 DELIM index_list . + + $default reduce using rule 242 (index_list) + + +state 405 + + 174 arglist: arglist DELIM arg . + + $default reduce using rule 174 (arglist) + + +state 406 + + 77 expr: expr0 . + 178 arg: ref '=' expr0 . + + Y_ALLPIPE reduce using rule 178 (arg) + Y_NEWLINE reduce using rule 178 (arg) + ';' reduce using rule 178 (arg) + '|' reduce using rule 178 (arg) + ',' reduce using rule 178 (arg) + ')' reduce using rule 178 (arg) + $default reduce using rule 77 (expr) + + +state 407 + + 78 expr: ref . + 179 arg: ref '=' ref . + + Y_ALLPIPE reduce using rule 179 (arg) + Y_NEWLINE reduce using rule 179 (arg) + ';' reduce using rule 179 (arg) + '|' reduce using rule 179 (arg) + ',' reduce using rule 179 (arg) + ')' reduce using rule 179 (arg) + $default reduce using rule 78 (expr) + + +state 408 + + 171 args: DELIM @20 arglist . + 174 arglist: arglist . DELIM arg + + ',' shift, and go to state 118 + + $default reduce using rule 171 (args) + + DELIM go to state 390 + + +state 409 + + 202 while: Y_WHILE LP @23 expr RP @24 opnl xstmt . + + $default reduce using rule 202 (while) + + +state 410 + + 86 expr1: expr . '+' opnl expr + 87 | expr . '-' opnl expr + 88 | expr . '*' opnl expr + 89 | expr . '/' opnl expr + 90 | expr . YOP_POW opnl expr + 91 | expr . '%' opnl expr + 92 | expr . YOP_CONCAT opnl expr + 93 | expr . '<' opnl expr + 94 | expr . '>' opnl expr + 95 | expr . YOP_LE opnl expr + 96 | expr . YOP_GE opnl expr + 97 | expr . YOP_EQ opnl expr + 98 | expr . YOP_NE opnl expr + 99 | expr . YOP_OR opnl expr + 100 | expr . YOP_AND opnl expr + 209 xexpr: expr . + + YOP_OR shift, and go to state 213 + YOP_AND shift, and go to state 214 + YOP_NE shift, and go to state 215 + YOP_EQ shift, and go to state 216 + '<' shift, and go to state 217 + '>' shift, and go to state 218 + YOP_GE shift, and go to state 219 + YOP_LE shift, and go to state 220 + YOP_CONCAT shift, and go to state 221 + '+' shift, and go to state 222 + '-' shift, and go to state 223 + '*' shift, and go to state 224 + '/' shift, and go to state 225 + '%' shift, and go to state 226 + YOP_POW shift, and go to state 227 + + $default reduce using rule 209 (xexpr) + + +state 411 + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 xexpr . ';' opnl @26 xassign RP opnl @27 stmt + + ';' shift, and go to state 415 + + +state 412 + + 212 switch: Y_SWITCH opnl LP opnl expr opnl RP opnl . @28 xstmt + + $default reduce using rule 211 (@28) + + @28 go to state 416 + + +state 413 + + 106 expr1: Y_SCANF LP @9 scanfmt DELIM scanarg RP . + + $default reduce using rule 106 (expr1) + + +state 414 + + 110 expr1: Y_FSCANF LP Y_IDENT DELIM @11 scanfmt DELIM . scanarg RP + + Y_IDENT shift, and go to state 318 + + $default reduce using rule 117 (scanarg) + + scanarg go to state 417 + + +state 415 + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 xexpr ';' . opnl @26 xassign RP opnl @27 stmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 418 + NL go to state 66 + + +state 416 + + 212 switch: Y_SWITCH opnl LP opnl expr opnl RP opnl @28 . xstmt + + error shift, and go to state 53 + Y_BOOL shift, and go to state 18 + Y_INT shift, and go to state 19 + Y_REAL shift, and go to state 20 + Y_STRING shift, and go to state 21 + Y_FILE shift, and go to state 22 + Y_STRUCT shift, and go to state 23 + Y_GCUR shift, and go to state 24 + Y_IMCUR shift, and go to state 25 + Y_UKEY shift, and go to state 26 + Y_PSET shift, and go to state 27 + + Y_OSESC reduce using rule 228 (@33) + Y_IDENT reduce using rule 228 (@33) + Y_WHILE reduce using rule 228 (@33) + Y_IF reduce using rule 228 (@33) + Y_FOR reduce using rule 228 (@33) + Y_BREAK reduce using rule 228 (@33) + Y_NEXT reduce using rule 228 (@33) + Y_SWITCH reduce using rule 228 (@33) + Y_CASE reduce using rule 228 (@33) + Y_DEFAULT reduce using rule 228 (@33) + Y_RETURN reduce using rule 228 (@33) + Y_GOTO reduce using rule 228 (@33) + '=' reduce using rule 228 (@33) + '{' reduce using rule 228 (@33) + ';' reduce using rule 228 (@33) + + var_decl_stmt go to state 54 + typedefs go to state 33 + xstmt go to state 419 + @33 go to state 56 + + +state 417 + + 110 expr1: Y_FSCANF LP Y_IDENT DELIM @11 scanfmt DELIM scanarg . RP + + ')' shift, and go to state 126 + + RP go to state 420 + + +state 418 + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 xexpr ';' opnl . @26 xassign RP opnl @27 stmt + + $default reduce using rule 204 (@26) + + @26 go to state 421 + + +state 419 + + 212 switch: Y_SWITCH opnl LP opnl expr opnl RP opnl @28 xstmt . + + $default reduce using rule 212 (switch) + + +state 420 + + 110 expr1: Y_FSCANF LP Y_IDENT DELIM @11 scanfmt DELIM scanarg RP . + + $default reduce using rule 110 (expr1) + + +state 421 + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 xexpr ';' opnl @26 . xassign RP opnl @27 stmt + + Y_IDENT shift, and go to state 37 + + $default reduce using rule 208 (xassign) + + assign go to state 258 + xassign go to state 422 + ref go to state 260 + param go to state 113 + + +state 422 + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 xexpr ';' opnl @26 xassign . RP opnl @27 stmt + + ')' shift, and go to state 126 + + RP go to state 423 + + +state 423 + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 xexpr ';' opnl @26 xassign RP . opnl @27 stmt + + Y_NEWLINE shift, and go to state 10 + + $default reduce using rule 235 (opnl) + + opnl go to state 424 + NL go to state 66 + + +state 424 + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 xexpr ';' opnl @26 xassign RP opnl . @27 stmt + + $default reduce using rule 205 (@27) + + @27 go to state 425 + + +state 425 + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 xexpr ';' opnl @26 xassign RP opnl @27 . stmt + + Y_OSESC shift, and go to state 72 + Y_IDENT shift, and go to state 73 + Y_WHILE shift, and go to state 74 + Y_IF shift, and go to state 75 + Y_FOR shift, and go to state 76 + Y_BREAK shift, and go to state 77 + Y_NEXT shift, and go to state 78 + Y_SWITCH shift, and go to state 79 + Y_CASE shift, and go to state 80 + Y_DEFAULT shift, and go to state 81 + Y_RETURN shift, and go to state 82 + Y_GOTO shift, and go to state 83 + '=' shift, and go to state 84 + '{' shift, and go to state 85 + ';' shift, and go to state 86 + + stmt go to state 426 + c_stmt go to state 88 + c_blk go to state 89 + assign go to state 90 + equals go to state 91 + cmdlist go to state 92 + command go to state 93 + immed go to state 94 + inspect go to state 95 + osesc go to state 96 + popstk go to state 97 + if go to state 98 + if_stat go to state 99 + ifelse go to state 100 + while go to state 101 + for go to state 102 + switch go to state 103 + case go to state 104 + default go to state 105 + next go to state 106 + break go to state 107 + return go to state 108 + label_stmt go to state 109 + goto go to state 110 + nullstmt go to state 111 + ref go to state 112 + param go to state 113 + tasknam go to state 114 + + +state 426 + + 206 for: Y_FOR LP opnl xassign ';' opnl @25 xexpr ';' opnl @26 xassign RP opnl @27 stmt . + + $default reduce using rule 206 (for) diff --git a/pkg/cl/ytab.c b/pkg/cl/ytab.c new file mode 100644 index 00000000..dfe7719b --- /dev/null +++ b/pkg/cl/ytab.c @@ -0,0 +1,4512 @@ +/* A Bison parser, made by GNU Bison 2.3. */ + +/* Skeleton implementation for Bison's Yacc-like parsers in C + + Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ + +/* As a special exception, you may create a larger work that contains + part or all of the Bison parser skeleton and distribute that work + under terms of your choice, so long as that work isn't itself a + parser generator using the skeleton or a modified version thereof + as a parser skeleton. Alternatively, if you modify or redistribute + the parser skeleton itself, you may (at your option) remove this + special exception, which will cause the skeleton and the resulting + Bison output files to be licensed under the GNU General Public + License without this special exception. + + This special exception was added by the Free Software Foundation in + version 2.2 of Bison. */ + +/* C LALR(1) parser skeleton written by Richard Stallman, by + simplifying the original so-called "semantic" parser. */ + +/* All symbols defined below should begin with yy or YY, to avoid + infringing on user name space. This should be done even for local + variables, as they might otherwise be expanded by user macros. + There are some unavoidable exceptions within include files to + define necessary library symbols; they are noted "INFRINGES ON + USER NAME SPACE" below. */ + +/* Identify Bison output. */ +#define YYBISON 1 + +/* Bison version. */ +#define YYBISON_VERSION "2.3" + +/* Skeleton name. */ +#define YYSKELETON_NAME "yacc.c" + +/* Pure parsers. */ +#define YYPURE 0 + +/* Using locations. */ +#define YYLSP_NEEDED 0 + + + +/* Tokens. */ +#ifndef YYTOKENTYPE +# define YYTOKENTYPE + /* Put the tokens into the symbol table, so that GDB and other debuggers + know about them. */ + enum yytokentype { + Y_SCAN = 258, + Y_SCANF = 259, + Y_FSCAN = 260, + Y_FSCANF = 261, + Y_OSESC = 262, + Y_APPEND = 263, + Y_ALLAPPEND = 264, + Y_ALLREDIR = 265, + Y_GSREDIR = 266, + Y_ALLPIPE = 267, + D_D = 268, + D_PEEK = 269, + Y_NEWLINE = 270, + Y_CONSTANT = 271, + Y_IDENT = 272, + Y_WHILE = 273, + Y_IF = 274, + Y_ELSE = 275, + Y_FOR = 276, + Y_BREAK = 277, + Y_NEXT = 278, + Y_SWITCH = 279, + Y_CASE = 280, + Y_DEFAULT = 281, + Y_RETURN = 282, + Y_GOTO = 283, + Y_PROCEDURE = 284, + Y_BEGIN = 285, + Y_END = 286, + Y_BOOL = 287, + Y_INT = 288, + Y_REAL = 289, + Y_STRING = 290, + Y_FILE = 291, + Y_STRUCT = 292, + Y_GCUR = 293, + Y_IMCUR = 294, + Y_UKEY = 295, + Y_PSET = 296, + YOP_AOCAT = 297, + YOP_AODIV = 298, + YOP_AOMUL = 299, + YOP_AOSUB = 300, + YOP_AOADD = 301, + YOP_OR = 302, + YOP_AND = 303, + YOP_NE = 304, + YOP_EQ = 305, + YOP_GE = 306, + YOP_LE = 307, + YOP_CONCAT = 308, + UMINUS = 309, + YOP_NOT = 310, + YOP_POW = 311 + }; +#endif +/* Tokens. */ +#define Y_SCAN 258 +#define Y_SCANF 259 +#define Y_FSCAN 260 +#define Y_FSCANF 261 +#define Y_OSESC 262 +#define Y_APPEND 263 +#define Y_ALLAPPEND 264 +#define Y_ALLREDIR 265 +#define Y_GSREDIR 266 +#define Y_ALLPIPE 267 +#define D_D 268 +#define D_PEEK 269 +#define Y_NEWLINE 270 +#define Y_CONSTANT 271 +#define Y_IDENT 272 +#define Y_WHILE 273 +#define Y_IF 274 +#define Y_ELSE 275 +#define Y_FOR 276 +#define Y_BREAK 277 +#define Y_NEXT 278 +#define Y_SWITCH 279 +#define Y_CASE 280 +#define Y_DEFAULT 281 +#define Y_RETURN 282 +#define Y_GOTO 283 +#define Y_PROCEDURE 284 +#define Y_BEGIN 285 +#define Y_END 286 +#define Y_BOOL 287 +#define Y_INT 288 +#define Y_REAL 289 +#define Y_STRING 290 +#define Y_FILE 291 +#define Y_STRUCT 292 +#define Y_GCUR 293 +#define Y_IMCUR 294 +#define Y_UKEY 295 +#define Y_PSET 296 +#define YOP_AOCAT 297 +#define YOP_AODIV 298 +#define YOP_AOMUL 299 +#define YOP_AOSUB 300 +#define YOP_AOADD 301 +#define YOP_OR 302 +#define YOP_AND 303 +#define YOP_NE 304 +#define YOP_EQ 305 +#define YOP_GE 306 +#define YOP_LE 307 +#define YOP_CONCAT 308 +#define UMINUS 309 +#define YOP_NOT 310 +#define YOP_POW 311 + + + + +/* Copy the first part of user declarations. */ +#line 1 "grammar.y" + + +#define import_spp +#define import_libc +#define import_stdio +#define import_ctype +#include + +#include "config.h" +#include "mem.h" +#include "operand.h" +#include "param.h" +#include "grammar.h" +#include "opcodes.h" +#include "clmodes.h" +#include "task.h" +#include "construct.h" +#include "errs.h" +#include "proto.h" + + +/* CL parser, written as a yacc grammar: + * build up an (rpn) instruction sequence begining at the base of the + * operand stack as the grammar is recognized. + * + * The parser may be called during parameter initialization (initiated by + * the CALL meta-code instruction), and to parse the executable portion + * (from the EXEC instruction). + * + * CONSTANT's are put on the dictionary by addconst() rather than the operand + * stack to avoid conflict with the code being created. They are accessed + * by using the yylval of IDENT and CONSTANT as dictionary indices that + * point to struct operands. This is facilitated with the stkop() macro. + * Make sure that topd and topcs are restored on return to discard these + * temporaries. + * When building offsets for branches, such as BIFF and GOTO, allow + * for the advancement of the pc by the size of the instruction (in ints). + * See opcodes.c for the code executed by the branch instructions. + */ + +extern int cldebug; +#define lint /* turns off sccsid in Yacc parser */ + +/* shorthand way to get at operands in dictionary. x will be values returned + * from addconst() by way of $n's from CONSTANT and IDENT tokens; see gram.c + * and its uses in grammar.l. also see pushop() for a description of the stack. + */ +#define stkop(x) (reference (operand, (x))) + +int dobkg = 0; /* set when want to do code in bkground */ +int npipes = 0; /* number of pipes in a command */ +XINT pipe_pc; /* pc of last ADDPIPE instruction */ +int posit = 0; /* positional argument count */ +int inarglist = 0; /* set when in argument list */ +int parenlevel = 0; /* level of paren nesting in command */ +int index_cnt; /* Index counter in array ref's */ +char curr_param[SZ_FNAME]; /* Parameter name of ref's */ +char curr_task[SZ_FNAME]; /* ltaskname of command */ +XINT stmt_pc; /* PC at beginning of current statement */ +int varlist; /* Declaration is list directed. */ +int vartype; /* Type of declaration. */ +int do_params; /* Are param definitions legal here? */ +int errcnt; /* Syntax error count. */ +int inited; /* Was variable already initialized. */ +struct param *pp; /* Pointer to param being compiled. */ +int n_aval; /* Number of array init values. */ +int lastref; /* Was last ref an array? */ +int for_expr; /* Was there an expression in FOR? */ +char *ifseen; /* Have we just processed an IF? */ + +/* context-sensitive switches. technique is ok, but beware of nesting! + */ +static int absmode = 0; /* set by first absolute mode arg in cmd*/ +static int newstdout = 0; /* set if stdout redirected in arg */ +static int bracelevel = 0; /* set while in s_list to inhibit & */ +static int tbrace = 0; /* fake braces for declarations */ +static int dobrace = 0; /* handling braces. */ +static int sawnl = 0; /* set when EOST was \n, else 0 */ +static int printstmt = 0; /* set when parsing FPRINT statement */ +static int scanstmt = 0; /* set when parsing SCAN statement */ + +/* printf-format error messages. + */ +char *posfirst = "All positional arguments must be first\n"; +/* char *look_parm= "Error searching for parameter `%s'."; */ +char *inval_arr= "Invalid array type for `%s'."; +char *inv_index= "Invalid index definition for `%s'."; +char *arrdeferr= "Error in array initialization for `%s'."; +/* char *arrinbrack="Array initialization must be in brackets for `%s'."; */ +char *badparm = "Parameter definition of `%s' is illegal here."; +char *illegalvar="Illegal variable declarations."; +char *locallist= "Local list variables are not permitted."; +char *twoinits = "Two initializations for parameter `%s'."; +char *exlimits = "Explicit range required for loop in external param.\n"; + +extern char cmdblk[SZ_CMDBLK+1]; /* Command buffer in history.c */ +extern char *ip_cmdblk; /* Pointer to current char in command.*/ +extern char *err_cmdblk; /* ip_cmdblk when error detected. */ + +char *index(); +struct param *initparam(); +struct label *getlabel(), *setlabel(); + +/* arbitrary large number for bracelevel in a procedure script + */ +#define MAX_ERR 10 +#define EYYERROR { err_cmdblk = ip_cmdblk; YYERROR; } + + + +/* Enabling traces. */ +#ifndef YYDEBUG +# define YYDEBUG 0 +#endif + +/* Enabling verbose error messages. */ +#ifdef YYERROR_VERBOSE +# undef YYERROR_VERBOSE +# define YYERROR_VERBOSE 1 +#else +# define YYERROR_VERBOSE 0 +#endif + +/* Enabling the token table. */ +#ifndef YYTOKEN_TABLE +# define YYTOKEN_TABLE 0 +#endif + +#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED +typedef int YYSTYPE; +# define yystype YYSTYPE /* obsolescent; will be withdrawn */ +# define YYSTYPE_IS_DECLARED 1 +# define YYSTYPE_IS_TRIVIAL 1 +#endif + + + +/* Copy the second part of user declarations. */ + + +/* Line 216 of yacc.c. */ +#line 328 "y.tab.c" + +#ifdef short +# undef short +#endif + +#ifdef YYTYPE_UINT8 +typedef YYTYPE_UINT8 yytype_uint8; +#else +typedef unsigned char yytype_uint8; +#endif + +#ifdef YYTYPE_INT8 +typedef YYTYPE_INT8 yytype_int8; +#elif (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +typedef signed char yytype_int8; +#else +typedef short int yytype_int8; +#endif + +#ifdef YYTYPE_UINT16 +typedef YYTYPE_UINT16 yytype_uint16; +#else +typedef unsigned short int yytype_uint16; +#endif + +#ifdef YYTYPE_INT16 +typedef YYTYPE_INT16 yytype_int16; +#else +typedef short int yytype_int16; +#endif + +#ifndef YYSIZE_T +# ifdef __SIZE_TYPE__ +# define YYSIZE_T __SIZE_TYPE__ +# elif defined size_t +# define YYSIZE_T size_t +# elif ! defined YYSIZE_T && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +# include /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T size_t +# else +# define YYSIZE_T unsigned int +# endif +#endif + +#define YYSIZE_MAXIMUM ((YYSIZE_T) -1) + +#ifndef YY_ +# if defined YYENABLE_NLS && YYENABLE_NLS +# if ENABLE_NLS +# include /* INFRINGES ON USER NAME SPACE */ +# define YY_(msgid) dgettext ("bison-runtime", msgid) +# endif +# endif +# ifndef YY_ +# define YY_(msgid) msgid +# endif +#endif + +/* Suppress unused-variable warnings by "using" E. */ +#if ! defined lint || defined __GNUC__ +# define YYUSE(e) ((void) (e)) +#else +# define YYUSE(e) /* empty */ +#endif + +/* Identity function, used to suppress warnings about constant conditions. */ +#ifndef lint +# define YYID(n) (n) +#else +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static int +YYID (int i) +#else +static int +YYID (i) + int i; +#endif +{ + return i; +} +#endif + +#if ! defined yyoverflow || YYERROR_VERBOSE + +/* The parser invokes alloca or malloc; define the necessary symbols. */ + +# ifdef YYSTACK_USE_ALLOCA +# if YYSTACK_USE_ALLOCA +# ifdef __GNUC__ +# define YYSTACK_ALLOC __builtin_alloca +# elif defined __BUILTIN_VA_ARG_INCR +# include /* INFRINGES ON USER NAME SPACE */ +# elif defined _AIX +# define YYSTACK_ALLOC __alloca +# elif defined _MSC_VER +# include /* INFRINGES ON USER NAME SPACE */ +# define alloca _alloca +# else +# define YYSTACK_ALLOC alloca +# if ! defined _ALLOCA_H && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +# include /* INFRINGES ON USER NAME SPACE */ +# ifndef _STDLIB_H +# define _STDLIB_H 1 +# endif +# endif +# endif +# endif +# endif + +# ifdef YYSTACK_ALLOC + /* Pacify GCC's `empty if-body' warning. */ +# define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0)) +# ifndef YYSTACK_ALLOC_MAXIMUM + /* The OS might guarantee only one guard page at the bottom of the stack, + and a page size can be as small as 4096 bytes. So we cannot safely + invoke alloca (N) if N exceeds 4096. Use a slightly smaller number + to allow for a few compiler-allocated temporary stack slots. */ +# define YYSTACK_ALLOC_MAXIMUM 4032 /* reasonable circa 2006 */ +# endif +# else +# define YYSTACK_ALLOC YYMALLOC +# define YYSTACK_FREE YYFREE +# ifndef YYSTACK_ALLOC_MAXIMUM +# define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM +# endif +# if (defined __cplusplus && ! defined _STDLIB_H \ + && ! ((defined YYMALLOC || defined malloc) \ + && (defined YYFREE || defined free))) +# include /* INFRINGES ON USER NAME SPACE */ +# ifndef _STDLIB_H +# define _STDLIB_H 1 +# endif +# endif +# ifndef YYMALLOC +# define YYMALLOC malloc +# if ! defined malloc && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */ +# endif +# endif +# ifndef YYFREE +# define YYFREE free +# if ! defined free && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +void free (void *); /* INFRINGES ON USER NAME SPACE */ +# endif +# endif +# endif +#endif /* ! defined yyoverflow || YYERROR_VERBOSE */ + + +#if (! defined yyoverflow \ + && (! defined __cplusplus \ + || (defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) + +/* A type that is properly aligned for any stack member. */ +union yyalloc +{ + yytype_int16 yyss; + YYSTYPE yyvs; + }; + +/* The size of the maximum gap between one aligned stack and the next. */ +# define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1) + +/* The size of an array large to enough to hold all stacks, each with + N elements. */ +# define YYSTACK_BYTES(N) \ + ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE)) \ + + YYSTACK_GAP_MAXIMUM) + +/* Copy COUNT objects from FROM to TO. The source and destination do + not overlap. */ +# ifndef YYCOPY +# if defined __GNUC__ && 1 < __GNUC__ +# define YYCOPY(To, From, Count) \ + __builtin_memcpy (To, From, (Count) * sizeof (*(From))) +# else +# define YYCOPY(To, From, Count) \ + do \ + { \ + YYSIZE_T yyi; \ + for (yyi = 0; yyi < (Count); yyi++) \ + (To)[yyi] = (From)[yyi]; \ + } \ + while (YYID (0)) +# endif +# endif + +/* Relocate STACK from its old location to the new one. The + local variables YYSIZE and YYSTACKSIZE give the old and new number of + elements in the stack, and YYPTR gives the new location of the + stack. Advance YYPTR to a properly aligned location for the next + stack. */ +# define YYSTACK_RELOCATE(Stack) \ + do \ + { \ + YYSIZE_T yynewbytes; \ + YYCOPY (&yyptr->Stack, Stack, yysize); \ + Stack = &yyptr->Stack; \ + yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ + yyptr += yynewbytes / sizeof (*yyptr); \ + } \ + while (YYID (0)) + +#endif + +/* YYFINAL -- State number of the termination state. */ +#define YYFINAL 15 +/* YYLAST -- Last index in YYTABLE. */ +#define YYLAST 947 + +/* YYNTOKENS -- Number of terminals. */ +#define YYNTOKENS 77 +/* YYNNTS -- Number of nonterminals. */ +#define YYNNTS 126 +/* YYNRULES -- Number of rules. */ +#define YYNRULES 260 +/* YYNRULES -- Number of states. */ +#define YYNSTATES 427 + +/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ +#define YYUNDEFTOK 2 +#define YYMAXUTOK 311 + +#define YYTRANSLATE(YYX) \ + ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) + +/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */ +static const yytype_uint8 yytranslate[] = +{ + 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 61, 2, 2, + 75, 76, 59, 57, 74, 58, 65, 60, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 72, 68, + 52, 42, 53, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 70, 2, 71, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 67, 73, 69, 66, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 1, 2, 3, 4, + 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, + 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, + 35, 36, 37, 38, 39, 40, 41, 43, 44, 45, + 46, 47, 48, 49, 50, 51, 54, 55, 56, 62, + 63, 64 +}; + +#if YYDEBUG +/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in + YYRHS. */ +static const yytype_uint16 yyprhs[] = +{ + 0, 0, 3, 4, 7, 8, 13, 15, 17, 20, + 21, 22, 27, 29, 32, 34, 38, 39, 45, 46, + 52, 53, 57, 58, 60, 62, 66, 67, 69, 71, + 74, 76, 78, 81, 82, 87, 89, 91, 93, 95, + 97, 99, 101, 103, 105, 107, 109, 113, 115, 121, + 123, 124, 129, 131, 132, 138, 140, 143, 144, 146, + 150, 152, 156, 158, 162, 164, 169, 171, 173, 176, + 178, 180, 184, 186, 188, 190, 194, 198, 201, 203, + 205, 207, 209, 211, 213, 215, 217, 221, 226, 231, + 236, 241, 246, 251, 256, 261, 266, 271, 276, 281, + 286, 291, 296, 299, 302, 303, 309, 310, 318, 319, + 325, 326, 336, 337, 343, 345, 347, 349, 351, 352, + 354, 358, 359, 361, 365, 367, 370, 373, 376, 379, + 382, 385, 387, 389, 391, 393, 395, 397, 399, 402, + 405, 408, 411, 413, 415, 417, 420, 421, 422, 429, + 430, 434, 438, 442, 443, 448, 450, 452, 454, 456, + 458, 460, 461, 465, 466, 467, 472, 475, 478, 479, + 480, 487, 488, 492, 494, 496, 500, 501, 503, 505, + 509, 513, 516, 519, 522, 525, 528, 531, 534, 537, + 539, 541, 544, 547, 550, 552, 554, 556, 557, 565, + 566, 572, 573, 574, 583, 584, 585, 586, 603, 605, + 606, 608, 609, 610, 621, 622, 623, 631, 632, 638, + 640, 642, 644, 647, 650, 651, 657, 660, 662, 665, + 666, 669, 671, 674, 676, 680, 682, 683, 685, 687, + 688, 694, 696, 697, 702, 704, 706, 708, 710, 712, + 714, 716, 718, 720, 722, 723, 725, 726, 728, 730, + 732 +}; + +/* YYRHS -- A `-1'-separated list of the rules' RHS. */ +static const yytype_int16 yyrhs[] = +{ + 78, 0, -1, -1, 65, 202, -1, -1, 78, 79, + 80, 183, -1, 83, -1, 84, -1, 1, 202, -1, + -1, -1, 82, 196, 81, 80, -1, 13, -1, 14, + 16, -1, 66, -1, 86, 91, 114, -1, -1, 114, + 85, 132, 187, 178, -1, -1, 29, 87, 194, 88, + 196, -1, -1, 200, 89, 201, -1, -1, 90, -1, + 194, -1, 90, 197, 194, -1, -1, 92, -1, 93, + -1, 92, 93, -1, 196, -1, 94, -1, 1, 202, + -1, -1, 96, 95, 97, 196, -1, 32, -1, 35, + -1, 34, -1, 36, -1, 38, -1, 39, -1, 40, + -1, 41, -1, 33, -1, 37, -1, 98, -1, 98, + 197, 97, -1, 99, -1, 99, 67, 111, 68, 69, + -1, 101, -1, -1, 101, 42, 100, 106, -1, 103, + -1, -1, 103, 102, 70, 104, 71, -1, 194, -1, + 59, 194, -1, -1, 105, -1, 104, 197, 105, -1, + 108, -1, 108, 72, 108, -1, 107, -1, 106, 197, + 107, -1, 108, -1, 16, 200, 108, 201, -1, 16, + -1, 109, -1, 110, 16, -1, 57, -1, 58, -1, + 106, 197, 112, -1, 106, -1, 112, -1, 113, -1, + 112, 197, 113, -1, 17, 42, 108, -1, 30, 202, + -1, 116, -1, 188, -1, 117, -1, 16, -1, 38, + -1, 39, -1, 40, -1, 41, -1, 200, 115, 201, + -1, 115, 57, 187, 115, -1, 115, 58, 187, 115, + -1, 115, 59, 187, 115, -1, 115, 60, 187, 115, + -1, 115, 64, 187, 115, -1, 115, 61, 187, 115, + -1, 115, 56, 187, 115, -1, 115, 52, 187, 115, + -1, 115, 53, 187, 115, -1, 115, 55, 187, 115, + -1, 115, 54, 187, 115, -1, 115, 51, 187, 115, + -1, 115, 50, 187, 115, -1, 115, 48, 187, 115, + -1, 115, 49, 187, 115, -1, 63, 115, -1, 58, + 115, -1, -1, 3, 200, 118, 125, 201, -1, -1, + 4, 200, 119, 124, 197, 125, 201, -1, -1, 5, + 200, 120, 125, 201, -1, -1, 6, 200, 17, 197, + 121, 124, 197, 125, 201, -1, -1, 123, 200, 122, + 126, 201, -1, 193, -1, 33, -1, 34, -1, 115, + -1, -1, 17, -1, 17, 197, 125, -1, -1, 115, + -1, 126, 197, 115, -1, 128, -1, 133, 196, -1, + 137, 196, -1, 150, 196, -1, 151, 196, -1, 152, + 196, -1, 153, 196, -1, 154, -1, 157, -1, 159, + -1, 162, -1, 168, -1, 170, -1, 173, -1, 175, + 196, -1, 176, 196, -1, 181, 196, -1, 177, 196, + -1, 179, -1, 182, -1, 129, -1, 129, 202, -1, + -1, -1, 67, 130, 132, 187, 131, 69, -1, -1, + 132, 187, 183, -1, 188, 135, 116, -1, 188, 135, + 188, -1, -1, 188, 134, 136, 115, -1, 42, -1, + 47, -1, 46, -1, 45, -1, 44, -1, 43, -1, + -1, 142, 138, 139, -1, -1, -1, 139, 141, 140, + 142, -1, 73, 187, -1, 12, 187, -1, -1, -1, + 195, 143, 198, 144, 145, 199, -1, -1, 197, 146, + 147, -1, 147, -1, 148, -1, 147, 197, 148, -1, + -1, 116, -1, 188, -1, 188, 42, 116, -1, 188, + 42, 188, -1, 194, 57, -1, 194, 58, -1, 52, + 149, -1, 53, 149, -1, 10, 149, -1, 8, 149, + -1, 9, 149, -1, 11, 149, -1, 116, -1, 194, + -1, 135, 116, -1, 135, 188, -1, 188, 135, -1, + 7, -1, 135, -1, 155, -1, -1, 19, 200, 115, + 201, 156, 187, 183, -1, -1, 155, 20, 158, 187, + 183, -1, -1, -1, 18, 200, 160, 115, 201, 161, + 187, 183, -1, -1, -1, -1, 21, 200, 187, 166, + 68, 187, 163, 167, 68, 187, 164, 166, 201, 187, + 165, 127, -1, 133, -1, -1, 115, -1, -1, -1, + 24, 187, 200, 187, 115, 187, 201, 187, 169, 183, + -1, -1, -1, 25, 171, 185, 72, 187, 172, 183, + -1, -1, 26, 72, 187, 174, 183, -1, 23, -1, + 22, -1, 27, -1, 27, 115, -1, 31, 202, -1, + -1, 17, 72, 187, 180, 183, -1, 28, 17, -1, + 68, -1, 68, 202, -1, -1, 184, 127, -1, 94, + -1, 1, 202, -1, 186, -1, 186, 197, 185, -1, + 16, -1, -1, 202, -1, 194, -1, -1, 194, 189, + 70, 190, 71, -1, 192, -1, -1, 192, 191, 197, + 190, -1, 117, -1, 188, -1, 59, -1, 16, -1, + 17, -1, 17, -1, 17, -1, 202, -1, 68, -1, + 74, -1, -1, 200, -1, -1, 201, -1, 75, -1, + 76, -1, 15, -1 +}; + +/* YYRLINE[YYN] -- source line where rule number YYN was defined. */ +static const yytype_uint16 yyrline[] = +{ + 0, 138, 138, 161, 173, 173, 193, 204, 216, 257, + 258, 258, 268, 271, 280, 285, 295, 295, 321, 321, + 343, 346, 352, 355, 358, 363, 370, 371, 374, 375, + 378, 379, 380, 417, 417, 454, 455, 456, 457, 458, + 459, 460, 461, 462, 463, 466, 467, 470, 488, 506, + 510, 510, 518, 523, 523, 542, 546, 557, 561, 562, + 566, 589, 606, 607, 610, 618, 639, 640, 646, 660, + 661, 663, 673, 681, 684, 685, 688, 695, 703, 704, + 717, 718, 722, 730, 734, 738, 744, 746, 750, 754, + 758, 762, 766, 775, 779, 783, 787, 791, 795, 799, + 803, 807, 811, 815, 820, 820, 833, 833, 850, 850, + 864, 864, 885, 885, 902, 903, 911, 917, 924, 930, + 936, 944, 947, 951, 960, 961, 962, 963, 964, 965, + 966, 967, 968, 969, 970, 971, 972, 973, 974, 975, + 976, 977, 978, 979, 985, 986, 989, 991, 989, 996, + 997, 1003, 1008, 1019, 1019, 1031, 1036, 1037, 1038, 1039, + 1040, 1043, 1043, 1054, 1055, 1055, 1100, 1103, 1108, 1132, + 1108, 1141, 1141, 1152, 1155, 1156, 1160, 1170, 1178, 1224, + 1229, 1241, 1246, 1251, 1255, 1260, 1265, 1270, 1275, 1281, + 1286, 1297, 1302, 1309, 1316, 1322, 1329, 1340, 1340, 1373, + 1373, 1396, 1403, 1396, 1441, 1445, 1461, 1441, 1490, 1491, + 1494, 1497, 1523, 1522, 1540, 1548, 1540, 1567, 1567, 1585, + 1600, 1624, 1628, 1640, 1652, 1652, 1686, 1708, 1709, 1716, + 1716, 1762, 1763, 1819, 1820, 1823, 1839, 1840, 1843, 1880, + 1880, 1895, 1898, 1898, 1904, 1908, 1915, 1936, 1970, 1975, + 1980, 1985, 1986, 1994, 1997, 1998, 2001, 2002, 2008, 2011, + 2014 +}; +#endif + +#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE +/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. + First, the terminals, then, starting at YYNTOKENS, nonterminals. */ +static const char *const yytname[] = +{ + "$end", "error", "$undefined", "Y_SCAN", "Y_SCANF", "Y_FSCAN", + "Y_FSCANF", "Y_OSESC", "Y_APPEND", "Y_ALLAPPEND", "Y_ALLREDIR", + "Y_GSREDIR", "Y_ALLPIPE", "D_D", "D_PEEK", "Y_NEWLINE", "Y_CONSTANT", + "Y_IDENT", "Y_WHILE", "Y_IF", "Y_ELSE", "Y_FOR", "Y_BREAK", "Y_NEXT", + "Y_SWITCH", "Y_CASE", "Y_DEFAULT", "Y_RETURN", "Y_GOTO", "Y_PROCEDURE", + "Y_BEGIN", "Y_END", "Y_BOOL", "Y_INT", "Y_REAL", "Y_STRING", "Y_FILE", + "Y_STRUCT", "Y_GCUR", "Y_IMCUR", "Y_UKEY", "Y_PSET", "'='", "YOP_AOCAT", + "YOP_AODIV", "YOP_AOMUL", "YOP_AOSUB", "YOP_AOADD", "YOP_OR", "YOP_AND", + "YOP_NE", "YOP_EQ", "'<'", "'>'", "YOP_GE", "YOP_LE", "YOP_CONCAT", + "'+'", "'-'", "'*'", "'/'", "'%'", "UMINUS", "YOP_NOT", "YOP_POW", "'.'", + "'~'", "'{'", "';'", "'}'", "'['", "']'", "':'", "'|'", "','", "'('", + "')'", "$accept", "block", "@1", "debug", "@2", "D_XXX", "script_params", + "script_body", "@3", "proc_stmt", "@4", "bparam_list", "param_list", + "xparam_list", "var_decls", "var_decl_block", "var_decl_line", + "var_decl_stmt", "@5", "typedefs", "var_decl_list", "var_decl_plus", + "var_decl", "@6", "var_def", "@7", "var_name", "init_index_list", + "init_index_range", "init_list", "init_elem", "const", "number", "sign", + "options_list", "options", "option", "begin_stmt", "expr", "expr0", + "expr1", "@8", "@9", "@10", "@11", "@12", "intrinsx", "scanfmt", + "scanarg", "intrarg", "stmt", "c_stmt", "c_blk", "@13", "@14", "s_list", + "assign", "@15", "equals", "assign_oper", "cmdlist", "@16", "cmdpipe", + "@17", "pipe", "command", "@18", "@19", "args", "@20", "arglist", "arg", + "file", "immed", "inspect", "osesc", "popstk", "if", "if_stat", "@21", + "ifelse", "@22", "while", "@23", "@24", "for", "@25", "@26", "@27", + "xassign", "xexpr", "switch", "@28", "case", "@29", "@30", "default", + "@31", "next", "break", "return", "end_stmt", "label_stmt", "@32", + "goto", "nullstmt", "xstmt", "@33", "const_expr_list", "const_expr", + "opnl", "ref", "@34", "index_list", "@35", "index", "intrins", "param", + "tasknam", "EOST", "DELIM", "BARG", "EARG", "LP", "RP", "NL", 0 +}; +#endif + +# ifdef YYPRINT +/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to + token YYLEX-NUM. */ +static const yytype_uint16 yytoknum[] = +{ + 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, + 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, 61, 297, 298, 299, 300, 301, 302, 303, + 304, 305, 60, 62, 306, 307, 308, 43, 45, 42, + 47, 37, 309, 310, 311, 46, 126, 123, 59, 125, + 91, 93, 58, 124, 44, 40, 41 +}; +# endif + +/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ +static const yytype_uint8 yyr1[] = +{ + 0, 77, 78, 78, 79, 78, 78, 78, 78, 80, + 81, 80, 82, 82, 82, 83, 85, 84, 87, 86, + 88, 88, 89, 89, 90, 90, 91, 91, 92, 92, + 93, 93, 93, 95, 94, 96, 96, 96, 96, 96, + 96, 96, 96, 96, 96, 97, 97, 98, 98, 99, + 100, 99, 101, 102, 101, 103, 103, 104, 104, 104, + 105, 105, 106, 106, 107, 107, 108, 108, 109, 110, + 110, 111, 111, 111, 112, 112, 113, 114, 115, 115, + 116, 116, 116, 116, 116, 116, 117, 117, 117, 117, + 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, + 117, 117, 117, 117, 118, 117, 119, 117, 120, 117, + 121, 117, 122, 117, 123, 123, 123, 124, 125, 125, + 125, 126, 126, 126, 127, 127, 127, 127, 127, 127, + 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, + 127, 127, 127, 127, 128, 128, 130, 131, 129, 132, + 132, 133, 133, 134, 133, 135, 136, 136, 136, 136, + 136, 138, 137, 139, 140, 139, 141, 141, 143, 144, + 142, 146, 145, 145, 147, 147, 148, 148, 148, 148, + 148, 148, 148, 148, 148, 148, 148, 148, 148, 149, + 149, 150, 150, 151, 152, 153, 154, 156, 155, 158, + 157, 160, 161, 159, 163, 164, 165, 162, 166, 166, + 167, 167, 169, 168, 171, 172, 170, 174, 173, 175, + 176, 177, 177, 178, 180, 179, 181, 182, 182, 184, + 183, 183, 183, 185, 185, 186, 187, 187, 188, 189, + 188, 190, 191, 190, 192, 192, 192, 192, 193, 194, + 195, 196, 196, 197, 198, 198, 199, 199, 200, 201, + 202 +}; + +/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ +static const yytype_uint8 yyr2[] = +{ + 0, 2, 0, 2, 0, 4, 1, 1, 2, 0, + 0, 4, 1, 2, 1, 3, 0, 5, 0, 5, + 0, 3, 0, 1, 1, 3, 0, 1, 1, 2, + 1, 1, 2, 0, 4, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 3, 1, 5, 1, + 0, 4, 1, 0, 5, 1, 2, 0, 1, 3, + 1, 3, 1, 3, 1, 4, 1, 1, 2, 1, + 1, 3, 1, 1, 1, 3, 3, 2, 1, 1, + 1, 1, 1, 1, 1, 1, 3, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 2, 2, 0, 5, 0, 7, 0, 5, + 0, 9, 0, 5, 1, 1, 1, 1, 0, 1, + 3, 0, 1, 3, 1, 2, 2, 2, 2, 2, + 2, 1, 1, 1, 1, 1, 1, 1, 2, 2, + 2, 2, 1, 1, 1, 2, 0, 0, 6, 0, + 3, 3, 3, 0, 4, 1, 1, 1, 1, 1, + 1, 0, 3, 0, 0, 4, 2, 2, 0, 0, + 6, 0, 3, 1, 1, 3, 0, 1, 1, 3, + 3, 2, 2, 2, 2, 2, 2, 2, 2, 1, + 1, 2, 2, 2, 1, 1, 1, 0, 7, 0, + 5, 0, 0, 8, 0, 0, 0, 16, 1, 0, + 1, 0, 0, 10, 0, 0, 7, 0, 5, 1, + 1, 1, 2, 2, 0, 5, 2, 1, 2, 0, + 2, 1, 2, 1, 3, 1, 0, 1, 1, 0, + 5, 1, 0, 4, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 0, 1, 0, 1, 1, 1, + 1 +}; + +/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state + STATE-NUM when YYTABLE doesn't specify something else to do. Zero + means the default is an error. */ +static const yytype_uint16 yydefact[] = +{ + 0, 0, 18, 0, 0, 4, 6, 7, 0, 16, + 260, 8, 0, 77, 3, 1, 9, 0, 35, 43, + 37, 36, 38, 44, 39, 40, 41, 42, 252, 0, + 0, 28, 31, 33, 30, 251, 149, 249, 20, 12, + 0, 14, 0, 0, 32, 15, 29, 0, 236, 258, + 0, 22, 13, 0, 231, 5, 0, 10, 0, 0, + 45, 47, 49, 52, 55, 0, 237, 19, 0, 23, + 24, 232, 194, 250, 0, 0, 0, 220, 219, 236, + 214, 0, 221, 0, 155, 146, 227, 230, 124, 144, + 0, 195, 0, 161, 0, 0, 0, 0, 131, 196, + 132, 133, 134, 135, 136, 137, 0, 0, 0, 142, + 0, 143, 153, 238, 168, 9, 56, 34, 253, 0, + 0, 50, 0, 0, 17, 150, 259, 21, 0, 236, + 201, 0, 236, 0, 0, 236, 0, 0, 0, 0, + 81, 249, 115, 116, 82, 83, 84, 85, 0, 0, + 222, 78, 80, 0, 79, 114, 0, 226, 149, 228, + 145, 125, 0, 78, 79, 126, 163, 127, 128, 129, + 130, 199, 138, 139, 141, 140, 0, 193, 0, 254, + 11, 46, 66, 0, 69, 70, 72, 62, 64, 67, + 0, 0, 73, 74, 0, 57, 223, 25, 224, 0, + 0, 209, 236, 235, 0, 233, 217, 104, 106, 108, + 0, 103, 102, 236, 236, 236, 236, 236, 236, 236, + 236, 236, 236, 236, 236, 236, 236, 236, 112, 0, + 236, 162, 236, 160, 159, 158, 157, 156, 0, 78, + 79, 0, 169, 255, 0, 0, 0, 68, 0, 0, + 51, 66, 0, 58, 60, 0, 0, 197, 208, 0, + 153, 0, 236, 0, 0, 118, 0, 118, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 121, 86, 0, 236, 236, 164, + 0, 154, 81, 246, 80, 79, 0, 241, 176, 0, + 76, 63, 71, 48, 75, 0, 54, 0, 0, 225, + 202, 236, 236, 0, 236, 215, 234, 218, 119, 0, + 117, 0, 0, 110, 100, 101, 99, 98, 94, 95, + 97, 96, 93, 87, 88, 89, 90, 92, 91, 122, + 0, 0, 167, 166, 0, 200, 240, 0, 0, 0, + 0, 0, 0, 0, 78, 256, 173, 174, 79, 238, + 171, 65, 59, 61, 236, 0, 204, 0, 0, 118, + 105, 118, 109, 0, 0, 113, 148, 250, 165, 0, + 78, 186, 238, 187, 185, 188, 183, 184, 170, 257, + 176, 0, 181, 182, 176, 0, 198, 211, 236, 216, + 120, 0, 0, 123, 243, 175, 78, 79, 172, 203, + 210, 0, 212, 107, 118, 236, 0, 0, 205, 213, + 111, 209, 0, 236, 206, 0, 207 +}; + +/* YYDEFGOTO[NTERM-NUM]. */ +static const yytype_int16 yydefgoto[] = +{ + -1, 5, 16, 42, 115, 43, 6, 7, 36, 8, + 12, 50, 68, 69, 29, 30, 31, 54, 47, 33, + 59, 60, 61, 194, 62, 122, 63, 252, 253, 186, + 187, 188, 189, 190, 191, 192, 193, 9, 162, 151, + 152, 265, 266, 267, 373, 284, 153, 321, 319, 340, + 87, 88, 89, 158, 341, 48, 90, 176, 91, 238, + 92, 166, 231, 344, 289, 93, 179, 298, 355, 394, + 356, 357, 381, 94, 95, 96, 97, 98, 99, 311, + 100, 232, 101, 199, 364, 102, 397, 421, 425, 259, + 411, 103, 416, 104, 134, 368, 105, 264, 106, 107, + 108, 124, 109, 255, 110, 111, 125, 56, 204, 205, + 65, 154, 178, 296, 347, 297, 155, 113, 114, 34, + 249, 242, 388, 156, 127, 66 +}; + +/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing + STATE-NUM. */ +#define YYPACT_NINF -261 +static const yytype_int16 yypact[] = +{ + 609, 0, -261, 0, 0, 14, -261, -261, 405, -261, + -261, -261, 6, -261, -261, -261, 47, 0, -261, -261, + -261, -261, -261, -261, -261, -261, -261, -261, -261, 3, + 447, -261, -261, -261, -261, -261, -261, -261, -35, -261, + 28, -261, 766, -6, -261, -261, -261, 35, 0, -261, + -6, 6, -261, 0, -261, -261, 802, -261, 6, -6, + -23, -10, 59, 22, -261, 714, -261, -261, 34, -23, + -261, -261, -261, -25, -35, -35, -35, -261, -261, 0, + -261, 53, 64, 104, -261, -261, 0, -261, -261, 0, + -6, 64, -6, -261, -6, -6, -6, -6, -261, 110, + -261, -261, -261, -261, -261, -261, -6, -6, -6, -261, + -6, -261, 89, 74, -261, 47, -261, -261, -261, 35, + 33, -261, 76, 0, -261, -261, -261, -261, 6, 0, + -261, 64, 0, -35, 132, 0, -35, -35, -35, -35, + -261, 75, -261, -261, -261, -261, -261, -261, 64, 64, + 852, -261, -261, -35, -261, -261, 64, -261, -261, -261, + -261, -261, 852, 19, 21, -261, -261, -261, -261, -261, + -261, -261, -261, -261, -261, -261, 112, 64, 105, -35, + -261, -261, -35, 138, -261, -261, -23, -261, -261, -261, + 172, 121, -23, -261, -4, 83, -261, -261, -261, 64, + 823, 6, 0, -261, 119, -23, -261, -261, -261, -261, + 178, 133, 133, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, -261, 823, + 0, -2, 0, -261, -261, -261, -261, -261, 64, 10, + 17, 25, -261, -261, 83, 83, 33, -261, 136, 184, + -23, -261, -47, -261, 135, 766, 823, -261, -261, 140, + 89, 64, 0, 132, 766, 198, 64, 198, -23, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 64, -261, 661, 0, 0, -261, + 766, 852, 41, -261, 43, 49, 147, 146, 515, 34, + -261, -261, -23, -261, -261, -4, -261, 83, 83, -261, + -261, 0, 0, 64, 797, -261, -261, -261, -23, 34, + 852, -23, 34, -261, 868, 883, 486, 486, 126, 126, + 126, 126, 169, 152, 152, 133, 133, 133, -261, 852, + 50, 156, -261, -261, 204, -261, -261, -23, 64, 64, + 64, 64, 64, 64, 207, 34, -23, -261, 311, 38, + -261, -261, -261, -261, 0, 766, -261, 34, 766, 198, + -261, 198, -261, 64, 64, -261, -261, -261, -261, 25, + 227, -261, 130, -261, -261, -261, -261, -261, -261, -261, + 554, 64, -261, -261, 554, 766, -261, 64, 0, -261, + -261, 34, -23, 852, -261, -261, 393, 460, -23, -261, + 852, 163, -261, -261, 198, 0, 766, 34, -261, -261, + -261, 6, 34, 0, -261, 802, -261 +}; + +/* YYPGOTO[NTERM-NUM]. */ +static const yytype_int16 yypgoto[] = +{ + -261, -261, -261, 122, -261, -261, -261, -261, -261, -261, + -261, -261, -261, -261, -261, -261, 206, 8, -261, -261, + 124, -261, -261, -261, -261, -261, -261, -261, -69, 51, + -233, -189, -261, -261, -261, -5, -3, 218, 120, -43, + -236, -261, -261, -261, -261, -261, -261, -125, -260, -261, + -173, -261, -261, -261, -261, 95, -197, -261, -109, -261, + -261, -261, -261, -261, -261, -90, -261, -261, -261, -261, + -138, -133, -37, -261, -261, -261, -261, -261, -261, -261, + -261, -261, -261, -261, -261, -261, -261, -261, -261, -159, + -261, -261, -261, -261, -261, -261, -261, -261, -261, -261, + -261, -261, -261, -261, -261, -261, -41, -261, 1, -261, + -53, -48, -261, -113, -261, -261, -261, -12, -261, 321, + -58, -261, -261, -1, -123, 406 +}; + +/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If + positive, shift that token. If negative, reduce the rule which + number is the opposite. If zero, do what YYDEFACT says. + If YYTABLE_NINF, syntax error. */ +#define YYTABLE_NINF -250 +static const yytype_int16 yytable[] = +{ + 38, 55, 119, 177, 258, 294, 254, 322, 112, 10, + 287, 128, 182, 301, 15, 10, 32, -249, -249, -249, + -249, -249, -249, 37, 306, -151, 133, 118, 136, 137, + 138, 139, -152, 3, -191, 64, -192, 51, 32, 70, + 49, 292, 141, 164, 52, -249, 116, 129, 163, 182, + 183, 118, 37, 184, 185, 299, 300, 120, 142, 143, + 39, 40, 28, 144, 145, 146, 147, 136, 137, 138, + 139, 288, 301, 130, 131, 132, 198, 257, -151, 201, + 140, 141, 206, 148, 293, -152, -151, -191, 149, -192, + 184, 185, -53, -152, 58, 392, 393, 142, 143, 251, + 49, 121, 144, 145, 146, 147, 285, 64, -239, 400, + 126, 401, -247, 41, -244, -247, 197, -244, 254, 363, + -245, 157, 148, -245, 118, 135, 126, 149, 246, 240, + 171, 84, 202, 310, 239, 207, 208, 209, 210, 49, + 184, 185, -190, 294, -239, -190, 195, 263, 203, 261, + -248, 313, 228, 260, 417, 233, 234, 235, 236, 237, + 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, + 279, 280, 281, 282, 283, 241, 361, 286, 243, 290, + 245, 244, 221, 222, 223, 224, 225, 226, 247, 248, + 227, 262, 305, 295, 307, 268, 370, 227, -190, 372, + -239, 183, 150, -190, -190, 303, -190, 308, 312, 315, + 323, 224, 225, 226, 309, 318, 227, 375, 346, -177, + -242, 377, -177, 317, 258, 376, 222, 223, 224, 225, + 226, 415, 389, 227, 342, 343, 46, 180, 362, -189, + 360, 302, -189, 181, 398, 250, 304, 45, 402, 345, + 358, 200, 426, 230, 378, 354, 408, 405, 365, 366, + 369, 367, 422, 371, 316, 240, 404, 0, 211, 212, + 239, 0, 0, 0, 0, -177, 229, 0, 413, 0, + -177, -177, 374, -177, 0, 0, 359, 0, 0, 379, + 0, 0, 0, 0, 420, -189, 0, 0, 390, 423, + -189, -189, 0, -189, 0, 380, 380, 380, 380, 380, + 380, 395, 383, 384, 385, 386, 387, 0, 0, 256, + 0, 0, 0, -178, 396, 0, -178, 399, 0, 0, + 0, 295, 0, 0, 0, 0, 382, 382, 382, 382, + 382, 382, 358, 407, 414, 412, 358, 354, 406, 0, + 390, 354, 0, 391, 409, 0, 0, 0, 291, 0, + 0, 0, 418, 0, 57, 0, 0, 0, 0, 0, + 424, 67, 0, 260, 0, 419, 0, 112, 359, -178, + 117, 314, 359, 0, -178, -178, 320, -178, 0, 324, + 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, + 335, 336, 337, 338, 339, -179, 17, 11, -179, 13, + 14, 161, 0, 165, 35, 167, 168, 169, 170, 0, + 10, 0, 0, 44, 0, 0, 0, 172, 173, 174, + 0, 175, 0, 0, 0, -26, 35, 18, 19, 20, + 21, 22, 23, 24, 25, 26, 27, 0, 17, 35, + 0, 0, 0, 0, 0, 0, 35, 0, 0, 71, + 0, -179, 10, 0, 0, 35, -179, -179, 0, -179, + 0, 0, -180, 28, 0, -180, 0, -27, 0, 18, + 19, 20, 21, 22, 23, 24, 25, 26, 27, 0, + 0, 0, 159, 320, 403, 160, 35, 0, 35, 0, + 35, 35, 35, 35, 0, 0, 0, 0, 0, 0, + 0, 0, 35, 35, 35, 28, 35, 410, 136, 137, + 138, 139, 0, 348, 349, 350, 351, 0, -180, 196, + 0, 140, 141, -180, -180, 0, -180, 0, 217, 218, + 219, 220, 221, 222, 223, 224, 225, 226, 142, 143, + 227, 0, 0, 144, 145, 146, 147, 136, 137, 138, + 139, 0, 348, 349, 350, 351, 0, 352, 353, 0, + 140, 141, 0, 148, 0, 0, 0, 0, 149, 0, + 0, 0, 0, 0, 0, 0, 0, 142, 143, 118, + 49, 0, 144, 145, 146, 147, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 352, 353, 0, -2, + 1, 0, 148, 0, 0, 0, -2, 149, 0, 0, + 0, 0, -2, -2, 0, 0, -2, -2, -2, 49, + -2, -2, -2, -2, -2, -2, -2, -2, 2, 3, + 0, -2, -2, -2, -2, -2, -2, -2, -2, -2, + -2, -2, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 53, 0, 0, 0, 0, 0, -229, 0, + 0, 0, 0, 0, 4, -2, -2, -2, -229, -229, + -229, 0, -229, -229, -229, -229, -229, -229, -229, -229, + 0, 0, 0, 18, 19, 20, 21, 22, 23, 24, + 25, 26, 27, -229, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 53, 0, 0, 0, 0, + 0, -229, 0, 0, 0, 0, 0, 0, -229, -229, + -147, -229, -229, -229, 0, -229, -229, -229, -229, -229, + -229, -229, -229, 0, 0, 123, 18, 19, 20, 21, + 22, 23, 24, 25, 26, 27, -229, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 53, 0, 0, + 0, 0, 0, -229, 0, 0, 0, 0, 0, 0, + 0, -229, -229, -229, -229, -229, 0, -229, -229, -229, + -229, -229, -229, -229, -229, 0, 0, 0, 18, 19, + 20, 21, 22, 23, 24, 25, 26, 27, -229, 72, + 0, 0, 10, 0, 0, 0, 0, 0, 0, 73, + 74, 75, 0, 76, 77, 78, 79, 80, 81, 82, + 83, 0, 0, -229, -229, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 84, 213, 214, 215, 216, 217, + 218, 219, 220, 221, 222, 223, 224, 225, 226, 0, + 0, 227, 0, 0, 0, 0, 0, 0, 0, 85, + 86, 213, 214, 215, 216, 217, 218, 219, 220, 221, + 222, 223, 224, 225, 226, 0, 0, 227, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 126, + 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, + 223, 224, 225, 226, 0, 0, 227, 214, 215, 216, + 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, + 0, 0, 227, 215, 216, 217, 218, 219, 220, 221, + 222, 223, 224, 225, 226, 0, 0, 227 +}; + +static const yytype_int16 yycheck[] = +{ + 12, 42, 60, 112, 201, 241, 195, 267, 56, 15, + 12, 69, 16, 246, 0, 15, 8, 42, 43, 44, + 45, 46, 47, 17, 71, 15, 79, 74, 3, 4, + 5, 6, 15, 30, 15, 47, 15, 38, 30, 51, + 75, 16, 17, 91, 16, 70, 58, 72, 91, 16, + 17, 74, 17, 57, 58, 244, 245, 67, 33, 34, + 13, 14, 68, 38, 39, 40, 41, 3, 4, 5, + 6, 73, 305, 74, 75, 76, 129, 200, 68, 132, + 16, 17, 135, 58, 59, 68, 76, 68, 63, 68, + 57, 58, 70, 76, 59, 57, 58, 33, 34, 16, + 75, 42, 38, 39, 40, 41, 229, 119, 70, 369, + 76, 371, 71, 66, 71, 74, 128, 74, 307, 308, + 71, 17, 58, 74, 74, 72, 76, 63, 186, 177, + 20, 42, 133, 256, 177, 136, 137, 138, 139, 75, + 57, 58, 12, 379, 70, 15, 70, 205, 16, 202, + 75, 260, 153, 201, 414, 43, 44, 45, 46, 47, + 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, + 223, 224, 225, 226, 227, 70, 299, 230, 179, 232, + 42, 182, 56, 57, 58, 59, 60, 61, 16, 68, + 64, 72, 250, 241, 252, 17, 319, 64, 68, 322, + 70, 17, 82, 73, 74, 69, 76, 72, 68, 262, + 268, 59, 60, 61, 255, 17, 64, 340, 71, 12, + 74, 17, 15, 264, 421, 69, 57, 58, 59, 60, + 61, 68, 355, 64, 287, 288, 30, 115, 307, 12, + 298, 246, 15, 119, 367, 194, 249, 29, 373, 290, + 298, 131, 425, 158, 344, 298, 394, 390, 311, 312, + 318, 314, 421, 321, 263, 313, 379, -1, 148, 149, + 313, -1, -1, -1, -1, 68, 156, -1, 401, -1, + 73, 74, 340, 76, -1, -1, 298, -1, -1, 347, + -1, -1, -1, -1, 417, 68, -1, -1, 356, 422, + 73, 74, -1, 76, -1, 348, 349, 350, 351, 352, + 353, 364, 349, 350, 351, 352, 353, -1, -1, 199, + -1, -1, -1, 12, 365, -1, 15, 368, -1, -1, + -1, 379, -1, -1, -1, -1, 348, 349, 350, 351, + 352, 353, 390, 391, 402, 398, 394, 390, 391, -1, + 408, 394, -1, 42, 395, -1, -1, -1, 238, -1, + -1, -1, 415, -1, 43, -1, -1, -1, -1, -1, + 423, 50, -1, 421, -1, 416, -1, 425, 390, 68, + 59, 261, 394, -1, 73, 74, 266, 76, -1, 269, + 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, + 280, 281, 282, 283, 284, 12, 1, 1, 15, 3, + 4, 90, -1, 92, 8, 94, 95, 96, 97, -1, + 15, -1, -1, 17, -1, -1, -1, 106, 107, 108, + -1, 110, -1, -1, -1, 30, 30, 32, 33, 34, + 35, 36, 37, 38, 39, 40, 41, -1, 1, 43, + -1, -1, -1, -1, -1, -1, 50, -1, -1, 53, + -1, 68, 15, -1, -1, 59, 73, 74, -1, 76, + -1, -1, 12, 68, -1, 15, -1, 30, -1, 32, + 33, 34, 35, 36, 37, 38, 39, 40, 41, -1, + -1, -1, 86, 373, 374, 89, 90, -1, 92, -1, + 94, 95, 96, 97, -1, -1, -1, -1, -1, -1, + -1, -1, 106, 107, 108, 68, 110, 397, 3, 4, + 5, 6, -1, 8, 9, 10, 11, -1, 68, 123, + -1, 16, 17, 73, 74, -1, 76, -1, 52, 53, + 54, 55, 56, 57, 58, 59, 60, 61, 33, 34, + 64, -1, -1, 38, 39, 40, 41, 3, 4, 5, + 6, -1, 8, 9, 10, 11, -1, 52, 53, -1, + 16, 17, -1, 58, -1, -1, -1, -1, 63, -1, + -1, -1, -1, -1, -1, -1, -1, 33, 34, 74, + 75, -1, 38, 39, 40, 41, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 52, 53, -1, 0, + 1, -1, 58, -1, -1, -1, 7, 63, -1, -1, + -1, -1, 13, 14, -1, -1, 17, 18, 19, 75, + 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, + -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, + 41, 42, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 1, -1, -1, -1, -1, -1, 7, -1, + -1, -1, -1, -1, 65, 66, 67, 68, 17, 18, + 19, -1, 21, 22, 23, 24, 25, 26, 27, 28, + -1, -1, -1, 32, 33, 34, 35, 36, 37, 38, + 39, 40, 41, 42, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 1, -1, -1, -1, -1, + -1, 7, -1, -1, -1, -1, -1, -1, 67, 68, + 69, 17, 18, 19, -1, 21, 22, 23, 24, 25, + 26, 27, 28, -1, -1, 31, 32, 33, 34, 35, + 36, 37, 38, 39, 40, 41, 42, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 1, -1, -1, + -1, -1, -1, 7, -1, -1, -1, -1, -1, -1, + -1, 67, 68, 17, 18, 19, -1, 21, 22, 23, + 24, 25, 26, 27, 28, -1, -1, -1, 32, 33, + 34, 35, 36, 37, 38, 39, 40, 41, 42, 7, + -1, -1, 15, -1, -1, -1, -1, -1, -1, 17, + 18, 19, -1, 21, 22, 23, 24, 25, 26, 27, + 28, -1, -1, 67, 68, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 42, 48, 49, 50, 51, 52, + 53, 54, 55, 56, 57, 58, 59, 60, 61, -1, + -1, 64, -1, -1, -1, -1, -1, -1, -1, 67, + 68, 48, 49, 50, 51, 52, 53, 54, 55, 56, + 57, 58, 59, 60, 61, -1, -1, 64, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 76, + 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, + 58, 59, 60, 61, -1, -1, 64, 49, 50, 51, + 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, + -1, -1, 64, 50, 51, 52, 53, 54, 55, 56, + 57, 58, 59, 60, 61, -1, -1, 64 +}; + +/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing + symbol of state STATE-NUM. */ +static const yytype_uint8 yystos[] = +{ + 0, 1, 29, 30, 65, 78, 83, 84, 86, 114, + 15, 202, 87, 202, 202, 0, 79, 1, 32, 33, + 34, 35, 36, 37, 38, 39, 40, 41, 68, 91, + 92, 93, 94, 96, 196, 202, 85, 17, 194, 13, + 14, 66, 80, 82, 202, 114, 93, 95, 132, 75, + 88, 200, 16, 1, 94, 183, 184, 196, 59, 97, + 98, 99, 101, 103, 194, 187, 202, 196, 89, 90, + 194, 202, 7, 17, 18, 19, 21, 22, 23, 24, + 25, 26, 27, 28, 42, 67, 68, 127, 128, 129, + 133, 135, 137, 142, 150, 151, 152, 153, 154, 155, + 157, 159, 162, 168, 170, 173, 175, 176, 177, 179, + 181, 182, 188, 194, 195, 81, 194, 196, 74, 197, + 67, 42, 102, 31, 178, 183, 76, 201, 197, 72, + 200, 200, 200, 187, 171, 72, 3, 4, 5, 6, + 16, 17, 33, 34, 38, 39, 40, 41, 58, 63, + 115, 116, 117, 123, 188, 193, 200, 17, 130, 202, + 202, 196, 115, 116, 188, 196, 138, 196, 196, 196, + 196, 20, 196, 196, 196, 196, 134, 135, 189, 143, + 80, 97, 16, 17, 57, 58, 106, 107, 108, 109, + 110, 111, 112, 113, 100, 70, 202, 194, 187, 160, + 115, 187, 200, 16, 185, 186, 187, 200, 200, 200, + 200, 115, 115, 48, 49, 50, 51, 52, 53, 54, + 55, 56, 57, 58, 59, 60, 61, 64, 200, 115, + 132, 139, 158, 43, 44, 45, 46, 47, 136, 116, + 188, 70, 198, 200, 200, 42, 197, 16, 68, 197, + 106, 16, 104, 105, 108, 180, 115, 201, 133, 166, + 188, 187, 72, 197, 174, 118, 119, 120, 17, 187, + 187, 187, 187, 187, 187, 187, 187, 187, 187, 187, + 187, 187, 187, 187, 122, 201, 187, 12, 73, 141, + 187, 115, 16, 59, 117, 188, 190, 192, 144, 108, + 108, 107, 112, 69, 113, 197, 71, 197, 72, 183, + 201, 156, 68, 135, 115, 187, 185, 183, 17, 125, + 115, 124, 125, 197, 115, 115, 115, 115, 115, 115, + 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, + 126, 131, 187, 187, 140, 183, 71, 191, 8, 9, + 10, 11, 52, 53, 116, 145, 147, 148, 188, 194, + 197, 201, 105, 108, 161, 187, 187, 187, 172, 197, + 201, 197, 201, 121, 197, 201, 69, 17, 142, 197, + 116, 149, 194, 149, 149, 149, 149, 149, 199, 201, + 197, 42, 57, 58, 146, 187, 183, 163, 201, 183, + 125, 125, 124, 115, 190, 148, 116, 188, 147, 183, + 115, 167, 187, 201, 197, 68, 169, 125, 187, 183, + 201, 164, 166, 201, 187, 165, 127 +}; + +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY (-2) +#define YYEOF 0 + +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrorlab + + +/* Like YYERROR except do call yyerror. This remains here temporarily + to ease the transition to the new meaning of YYERROR, for GCC. + Once GCC version 2 has supplanted version 1, this can go. */ + +#define YYFAIL goto yyerrlab + +#define YYRECOVERING() (!!yyerrstatus) + +#define YYBACKUP(Token, Value) \ +do \ + if (yychar == YYEMPTY && yylen == 1) \ + { \ + yychar = (Token); \ + yylval = (Value); \ + yytoken = YYTRANSLATE (yychar); \ + YYPOPSTACK (1); \ + goto yybackup; \ + } \ + else \ + { \ + yyerror (YY_("syntax error: cannot back up")); \ + YYERROR; \ + } \ +while (YYID (0)) + + +#define YYTERROR 1 +#define YYERRCODE 256 + + +/* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N]. + If N is 0, then set CURRENT to the empty location which ends + the previous symbol: RHS[0] (always defined). */ + +#define YYRHSLOC(Rhs, K) ((Rhs)[K]) +#ifndef YYLLOC_DEFAULT +# define YYLLOC_DEFAULT(Current, Rhs, N) \ + do \ + if (YYID (N)) \ + { \ + (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ + (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ + (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ + (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ + } \ + else \ + { \ + (Current).first_line = (Current).last_line = \ + YYRHSLOC (Rhs, 0).last_line; \ + (Current).first_column = (Current).last_column = \ + YYRHSLOC (Rhs, 0).last_column; \ + } \ + while (YYID (0)) +#endif + + +/* YY_LOCATION_PRINT -- Print the location on the stream. + This macro was not mandated originally: define only if we know + we won't break user code: when these are the locations we know. */ + +#ifndef YY_LOCATION_PRINT +# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL +# define YY_LOCATION_PRINT(File, Loc) \ + fprintf (File, "%d.%d-%d.%d", \ + (Loc).first_line, (Loc).first_column, \ + (Loc).last_line, (Loc).last_column) +# else +# define YY_LOCATION_PRINT(File, Loc) ((void) 0) +# endif +#endif + + +/* YYLEX -- calling `yylex' with the right arguments. */ + +#ifdef YYLEX_PARAM +# define YYLEX yylex (YYLEX_PARAM) +#else +# define YYLEX yylex () +#endif + +/* Enable debugging if requested. */ +#if YYDEBUG + +# ifndef YYFPRINTF +# include /* INFRINGES ON USER NAME SPACE */ +# define YYFPRINTF fprintf +# endif + +# define YYDPRINTF(Args) \ +do { \ + if (yydebug) \ + YYFPRINTF Args; \ +} while (YYID (0)) + +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ +do { \ + if (yydebug) \ + { \ + YYFPRINTF (stderr, "%s ", Title); \ + yy_symbol_print (stderr, \ + Type, Value); \ + YYFPRINTF (stderr, "\n"); \ + } \ +} while (YYID (0)) + + +/*--------------------------------. +| Print this symbol on YYOUTPUT. | +`--------------------------------*/ + +/*ARGSUSED*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep) +#else +static void +yy_symbol_value_print (yyoutput, yytype, yyvaluep) + FILE *yyoutput; + int yytype; + YYSTYPE const * const yyvaluep; +#endif +{ + if (!yyvaluep) + return; +# ifdef YYPRINT + if (yytype < YYNTOKENS) + YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); +# else + YYUSE (yyoutput); +# endif + switch (yytype) + { + default: + break; + } +} + + +/*--------------------------------. +| Print this symbol on YYOUTPUT. | +`--------------------------------*/ + +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep) +#else +static void +yy_symbol_print (yyoutput, yytype, yyvaluep) + FILE *yyoutput; + int yytype; + YYSTYPE const * const yyvaluep; +#endif +{ + if (yytype < YYNTOKENS) + YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); + else + YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); + + yy_symbol_value_print (yyoutput, yytype, yyvaluep); + YYFPRINTF (yyoutput, ")"); +} + +/*------------------------------------------------------------------. +| yy_stack_print -- Print the state stack from its BOTTOM up to its | +| TOP (included). | +`------------------------------------------------------------------*/ + +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_stack_print (yytype_int16 *bottom, yytype_int16 *top) +#else +static void +yy_stack_print (bottom, top) + yytype_int16 *bottom; + yytype_int16 *top; +#endif +{ + YYFPRINTF (stderr, "Stack now"); + for (; bottom <= top; ++bottom) + YYFPRINTF (stderr, " %d", *bottom); + YYFPRINTF (stderr, "\n"); +} + +# define YY_STACK_PRINT(Bottom, Top) \ +do { \ + if (yydebug) \ + yy_stack_print ((Bottom), (Top)); \ +} while (YYID (0)) + + +/*------------------------------------------------. +| Report that the YYRULE is going to be reduced. | +`------------------------------------------------*/ + +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_reduce_print (YYSTYPE *yyvsp, int yyrule) +#else +static void +yy_reduce_print (yyvsp, yyrule) + YYSTYPE *yyvsp; + int yyrule; +#endif +{ + int yynrhs = yyr2[yyrule]; + int yyi; + unsigned long int yylno = yyrline[yyrule]; + YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n", + yyrule - 1, yylno); + /* The symbols being reduced. */ + for (yyi = 0; yyi < yynrhs; yyi++) + { + fprintf (stderr, " $%d = ", yyi + 1); + yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi], + &(yyvsp[(yyi + 1) - (yynrhs)]) + ); + fprintf (stderr, "\n"); + } +} + +# define YY_REDUCE_PRINT(Rule) \ +do { \ + if (yydebug) \ + yy_reduce_print (yyvsp, Rule); \ +} while (YYID (0)) + +/* Nonzero means print parse trace. It is left uninitialized so that + multiple parsers can coexist. */ +int yydebug; +#else /* !YYDEBUG */ +# define YYDPRINTF(Args) +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) +# define YY_STACK_PRINT(Bottom, Top) +# define YY_REDUCE_PRINT(Rule) +#endif /* !YYDEBUG */ + + +/* YYINITDEPTH -- initial size of the parser's stacks. */ +#ifndef YYINITDEPTH +# define YYINITDEPTH 200 +#endif + +/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only + if the built-in stack extension method is used). + + Do not make this value too large; the results are undefined if + YYSTACK_ALLOC_MAXIMUM < YYSTACK_BYTES (YYMAXDEPTH) + evaluated with infinite-precision integer arithmetic. */ + +#ifndef YYMAXDEPTH +# define YYMAXDEPTH 10000 +#endif + + + +#if YYERROR_VERBOSE + +# ifndef yystrlen +# if defined __GLIBC__ && defined _STRING_H +# define yystrlen strlen +# else +/* Return the length of YYSTR. */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static YYSIZE_T +yystrlen (const char *yystr) +#else +static YYSIZE_T +yystrlen (yystr) + const char *yystr; +#endif +{ + YYSIZE_T yylen; + for (yylen = 0; yystr[yylen]; yylen++) + continue; + return yylen; +} +# endif +# endif + +# ifndef yystpcpy +# if defined __GLIBC__ && defined _STRING_H && defined _GNU_SOURCE +# define yystpcpy stpcpy +# else +/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in + YYDEST. */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static char * +yystpcpy (char *yydest, const char *yysrc) +#else +static char * +yystpcpy (yydest, yysrc) + char *yydest; + const char *yysrc; +#endif +{ + char *yyd = yydest; + const char *yys = yysrc; + + while ((*yyd++ = *yys++) != '\0') + continue; + + return yyd - 1; +} +# endif +# endif + +# ifndef yytnamerr +/* Copy to YYRES the contents of YYSTR after stripping away unnecessary + quotes and backslashes, so that it's suitable for yyerror. The + heuristic is that double-quoting is unnecessary unless the string + contains an apostrophe, a comma, or backslash (other than + backslash-backslash). YYSTR is taken from yytname. If YYRES is + null, do not copy; instead, return the length of what the result + would have been. */ +static YYSIZE_T +yytnamerr (char *yyres, const char *yystr) +{ + if (*yystr == '"') + { + YYSIZE_T yyn = 0; + char const *yyp = yystr; + + for (;;) + switch (*++yyp) + { + case '\'': + case ',': + goto do_not_strip_quotes; + + case '\\': + if (*++yyp != '\\') + goto do_not_strip_quotes; + /* Fall through. */ + default: + if (yyres) + yyres[yyn] = *yyp; + yyn++; + break; + + case '"': + if (yyres) + yyres[yyn] = '\0'; + return yyn; + } + do_not_strip_quotes: ; + } + + if (! yyres) + return yystrlen (yystr); + + return yystpcpy (yyres, yystr) - yyres; +} +# endif + +/* Copy into YYRESULT an error message about the unexpected token + YYCHAR while in state YYSTATE. Return the number of bytes copied, + including the terminating null byte. If YYRESULT is null, do not + copy anything; just return the number of bytes that would be + copied. As a special case, return 0 if an ordinary "syntax error" + message will do. Return YYSIZE_MAXIMUM if overflow occurs during + size calculation. */ +static YYSIZE_T +yysyntax_error (char *yyresult, int yystate, int yychar) +{ + int yyn = yypact[yystate]; + + if (! (YYPACT_NINF < yyn && yyn <= YYLAST)) + return 0; + else + { + int yytype = YYTRANSLATE (yychar); + YYSIZE_T yysize0 = yytnamerr (0, yytname[yytype]); + YYSIZE_T yysize = yysize0; + YYSIZE_T yysize1; + int yysize_overflow = 0; + enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; + char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; + int yyx; + +# if 0 + /* This is so xgettext sees the translatable formats that are + constructed on the fly. */ + YY_("syntax error, unexpected %s"); + YY_("syntax error, unexpected %s, expecting %s"); + YY_("syntax error, unexpected %s, expecting %s or %s"); + YY_("syntax error, unexpected %s, expecting %s or %s or %s"); + YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s"); +# endif + char *yyfmt; + char const *yyf; + static char const yyunexpected[] = "syntax error, unexpected %s"; + static char const yyexpecting[] = ", expecting %s"; + static char const yyor[] = " or %s"; + char yyformat[sizeof yyunexpected + + sizeof yyexpecting - 1 + + ((YYERROR_VERBOSE_ARGS_MAXIMUM - 2) + * (sizeof yyor - 1))]; + char const *yyprefix = yyexpecting; + + /* Start YYX at -YYN if negative to avoid negative indexes in + YYCHECK. */ + int yyxbegin = yyn < 0 ? -yyn : 0; + + /* Stay within bounds of both yycheck and yytname. */ + int yychecklim = YYLAST - yyn + 1; + int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; + int yycount = 1; + + yyarg[0] = yytname[yytype]; + yyfmt = yystpcpy (yyformat, yyunexpected); + + for (yyx = yyxbegin; yyx < yyxend; ++yyx) + if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) + { + if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) + { + yycount = 1; + yysize = yysize0; + yyformat[sizeof yyunexpected - 1] = '\0'; + break; + } + yyarg[yycount++] = yytname[yyx]; + yysize1 = yysize + yytnamerr (0, yytname[yyx]); + yysize_overflow |= (yysize1 < yysize); + yysize = yysize1; + yyfmt = yystpcpy (yyfmt, yyprefix); + yyprefix = yyor; + } + + yyf = YY_(yyformat); + yysize1 = yysize + yystrlen (yyf); + yysize_overflow |= (yysize1 < yysize); + yysize = yysize1; + + if (yysize_overflow) + return YYSIZE_MAXIMUM; + + if (yyresult) + { + /* Avoid sprintf, as that infringes on the user's name space. + Don't have undefined behavior even if the translation + produced a string with the wrong number of "%s"s. */ + char *yyp = yyresult; + int yyi = 0; + while ((*yyp = *yyf) != '\0') + { + if (*yyp == '%' && yyf[1] == 's' && yyi < yycount) + { + yyp += yytnamerr (yyp, yyarg[yyi++]); + yyf += 2; + } + else + { + yyp++; + yyf++; + } + } + } + return yysize; + } +} +#endif /* YYERROR_VERBOSE */ + + +/*-----------------------------------------------. +| Release the memory associated to this symbol. | +`-----------------------------------------------*/ + +/*ARGSUSED*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep) +#else +static void +yydestruct (yymsg, yytype, yyvaluep) + const char *yymsg; + int yytype; + YYSTYPE *yyvaluep; +#endif +{ + YYUSE (yyvaluep); + + if (!yymsg) + yymsg = "Deleting"; + YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); + + switch (yytype) + { + + default: + break; + } +} + + +/* Prevent warnings from -Wmissing-prototypes. */ + +#ifdef YYPARSE_PARAM +#if defined __STDC__ || defined __cplusplus +int yyparse (void *YYPARSE_PARAM); +#else +int yyparse (); +#endif +#else /* ! YYPARSE_PARAM */ +#if defined __STDC__ || defined __cplusplus +int yyparse (void); +#else +int yyparse (); +#endif +#endif /* ! YYPARSE_PARAM */ + + + +/* The look-ahead symbol. */ +int yychar; + +/* The semantic value of the look-ahead symbol. */ +YYSTYPE yylval; + +/* Number of syntax errors so far. */ +int yynerrs; + + + +/*----------. +| yyparse. | +`----------*/ + +#ifdef YYPARSE_PARAM +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +int +yyparse (void *YYPARSE_PARAM) +#else +int +yyparse (YYPARSE_PARAM) + void *YYPARSE_PARAM; +#endif +#else /* ! YYPARSE_PARAM */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +int +yyparse (void) +#else +int +yyparse () + +#endif +#endif +{ + + int yystate; + int yyn; + int yyresult; + /* Number of tokens to shift before error messages enabled. */ + int yyerrstatus; + /* Look-ahead token as an internal (translated) token number. */ + int yytoken = 0; +#if YYERROR_VERBOSE + /* Buffer for error messages, and its allocated size. */ + char yymsgbuf[128]; + char *yymsg = yymsgbuf; + YYSIZE_T yymsg_alloc = sizeof yymsgbuf; +#endif + + /* Three stacks and their tools: + `yyss': related to states, + `yyvs': related to semantic values, + `yyls': related to locations. + + Refer to the stacks thru separate pointers, to allow yyoverflow + to reallocate them elsewhere. */ + + /* The state stack. */ + yytype_int16 yyssa[YYINITDEPTH]; + yytype_int16 *yyss = yyssa; + yytype_int16 *yyssp; + + /* The semantic value stack. */ + YYSTYPE yyvsa[YYINITDEPTH]; + YYSTYPE *yyvs = yyvsa; + YYSTYPE *yyvsp; + + + +#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N)) + + YYSIZE_T yystacksize = YYINITDEPTH; + + /* The variables used to return semantic value and location from the + action routines. */ + YYSTYPE yyval; + + + /* The number of symbols on the RHS of the reduced rule. + Keep to zero when no symbol should be popped. */ + int yylen = 0; + + YYDPRINTF ((stderr, "Starting parse\n")); + + yystate = 0; + yyerrstatus = 0; + yynerrs = 0; + yychar = YYEMPTY; /* Cause a token to be read. */ + + /* Initialize stack pointers. + Waste one element of value and location stack + so that they stay on the same level as the state stack. + The wasted elements are never initialized. */ + + yyssp = yyss; + yyvsp = yyvs; + + goto yysetstate; + +/*------------------------------------------------------------. +| yynewstate -- Push a new state, which is found in yystate. | +`------------------------------------------------------------*/ + yynewstate: + /* In all cases, when you get here, the value and location stacks + have just been pushed. So pushing a state here evens the stacks. */ + yyssp++; + + yysetstate: + *yyssp = yystate; + + if (yyss + yystacksize - 1 <= yyssp) + { + /* Get the current used size of the three stacks, in elements. */ + YYSIZE_T yysize = yyssp - yyss + 1; + +#ifdef yyoverflow + { + /* Give user a chance to reallocate the stack. Use copies of + these so that the &'s don't force the real ones into + memory. */ + YYSTYPE *yyvs1 = yyvs; + yytype_int16 *yyss1 = yyss; + + + /* Each stack pointer address is followed by the size of the + data in use in that stack, in bytes. This used to be a + conditional around just the two extra args, but that might + be undefined if yyoverflow is a macro. */ + yyoverflow (YY_("memory exhausted"), + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + + &yystacksize); + + yyss = yyss1; + yyvs = yyvs1; + } +#else /* no yyoverflow */ +# ifndef YYSTACK_RELOCATE + goto yyexhaustedlab; +# else + /* Extend the stack our own way. */ + if (YYMAXDEPTH <= yystacksize) + goto yyexhaustedlab; + yystacksize *= 2; + if (YYMAXDEPTH < yystacksize) + yystacksize = YYMAXDEPTH; + + { + yytype_int16 *yyss1 = yyss; + union yyalloc *yyptr = + (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); + if (! yyptr) + goto yyexhaustedlab; + YYSTACK_RELOCATE (yyss); + YYSTACK_RELOCATE (yyvs); + +# undef YYSTACK_RELOCATE + if (yyss1 != yyssa) + YYSTACK_FREE (yyss1); + } +# endif +#endif /* no yyoverflow */ + + yyssp = yyss + yysize - 1; + yyvsp = yyvs + yysize - 1; + + + YYDPRINTF ((stderr, "Stack size increased to %lu\n", + (unsigned long int) yystacksize)); + + if (yyss + yystacksize - 1 <= yyssp) + YYABORT; + } + + YYDPRINTF ((stderr, "Entering state %d\n", yystate)); + + goto yybackup; + +/*-----------. +| yybackup. | +`-----------*/ +yybackup: + + /* Do appropriate processing given the current state. Read a + look-ahead token if we need one and don't already have one. */ + + /* First try to decide what to do without reference to look-ahead token. */ + yyn = yypact[yystate]; + if (yyn == YYPACT_NINF) + goto yydefault; + + /* Not known => get a look-ahead token if don't already have one. */ + + /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */ + if (yychar == YYEMPTY) + { + YYDPRINTF ((stderr, "Reading a token: ")); + yychar = YYLEX; + } + + if (yychar <= YYEOF) + { + yychar = yytoken = YYEOF; + YYDPRINTF ((stderr, "Now at end of input.\n")); + } + else + { + yytoken = YYTRANSLATE (yychar); + YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc); + } + + /* If the proper action on seeing token YYTOKEN is to reduce or to + detect an error, take that action. */ + yyn += yytoken; + if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken) + goto yydefault; + yyn = yytable[yyn]; + if (yyn <= 0) + { + if (yyn == 0 || yyn == YYTABLE_NINF) + goto yyerrlab; + yyn = -yyn; + goto yyreduce; + } + + if (yyn == YYFINAL) + YYACCEPT; + + /* Count tokens shifted since error; after three, turn off error + status. */ + if (yyerrstatus) + yyerrstatus--; + + /* Shift the look-ahead token. */ + YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); + + /* Discard the shifted token unless it is eof. */ + if (yychar != YYEOF) + yychar = YYEMPTY; + + yystate = yyn; + *++yyvsp = yylval; + + goto yynewstate; + + +/*-----------------------------------------------------------. +| yydefault -- do the default action for the current state. | +`-----------------------------------------------------------*/ +yydefault: + yyn = yydefact[yystate]; + if (yyn == 0) + goto yyerrlab; + goto yyreduce; + + +/*-----------------------------. +| yyreduce -- Do a reduction. | +`-----------------------------*/ +yyreduce: + /* yyn is the number of a rule to reduce with. */ + yylen = yyr2[yyn]; + + /* If YYLEN is nonzero, implement the default value of the action: + `$$ = $1'. + + Otherwise, the following line sets YYVAL to garbage. + This behavior is undocumented and Bison + users should not rely upon it. Assigning to YYVAL + unconditionally makes the parser a bit smaller, and it avoids a + GCC warning that YYVAL may be used uninitialized. */ + yyval = yyvsp[1-yylen]; + + + YY_REDUCE_PRINT (yyn); + switch (yyn) + { + case 2: +#line 138 "grammar.y" + { + /* Done once on entry but after at least one call to + * yylex(). Good for initing parser flags. + * Note: this does not get called in procedure scripts. + */ + if (cldebug) + eprintf ("parse init (block)...\n"); + + errcnt = 0; + err_cmdblk = 0; + dobkg = 0; + inarglist = 0; + parenlevel = 0; + bracelevel = 0; + tbrace = 0; + dobrace = 0; + do_params = YES; + last_parm = NULL; + ifseen = NULL; + label1 = NULL; + parse_pfile= currentask->t_pfp; + } + break; + + case 3: +#line 161 "grammar.y" + { + /* Prepare to rerun whatever was compiled last. + * Does not work for the debug commands builtin here. + */ + if (parse_state != PARSE_FREE) { + eprintf ("Illegal parser state.\n"); + EYYERROR; + } + rerun(); + YYACCEPT; + } + break; + + case 4: +#line 173 "grammar.y" + { + if (parse_state == PARSE_PARAMS) { + eprintf ("Illegal parser state.\n"); + EYYERROR; + } + } + break; + + case 5: +#line 179 "grammar.y" + { + if (sawnl && bracelevel == 0) { + if (!errcnt) + compile (END); + if (ifseen) { + /* Simulate an unput of what has been read + * from the current line. + */ + ip_cmdblk = ifseen; + } + YYACCEPT; + } + } + break; + + case 6: +#line 193 "grammar.y" + { + /* Parse the parameters in a script file. This will + * normally be done on a call by pfileread(). + */ + if (parse_state != PARSE_PARAMS) { + eprintf ("Illegal parser state.\n"); + errcnt++; + } + YYACCEPT; + } + break; + + case 7: +#line 204 "grammar.y" + { + /* Parse the executable statements in a script. + */ + if (parse_state != PARSE_BODY) { + eprintf ("Illegal parser state.\n"); + errcnt++; + } + if (!errcnt) + compile (END); + YYACCEPT; + } + break; + + case 8: +#line 216 "grammar.y" + { + /* This catches errors that the two other error lines + * can't get, e.g. a missing `}' at the end of a script, + * or errors occuring in interactive input. + */ + yyerrok; + + /* Discard everything and compile a null statement. + */ + if (!errcnt) { + do_params = YES; + pc = currentask->t_bascode; + if (parse_state != PARSE_PARAMS) + compile (END); + + topd = currentask->t_topd; + topcs = currentask->t_topcs; + + /* Unlink any added parms. Resetting of topd will + * already have reclaimed space. + */ + if (last_parm) { + last_parm->p_np = NULL; + currentask->t_pfp->pf_lastpp = last_parm; + last_parm = NULL; + } + } + + /* Print cmdblk and show position of error. + */ + p_position(); + if (currentask->t_flags & T_SCRIPT) + cl_error (E_UERR, "syntax error, line %d", + currentask->t_scriptln); + else + cl_error (E_UERR, "syntax error"); + + YYACCEPT; + } + break; + + case 10: +#line 258 "grammar.y" + { + /* debug are those debugging functions that + * should be run directly and not through a + * builtin task due to stack or other changes, + * ie, don't change what we are trying to show. + */ + printf ("\n"); + } + break; + + case 12: +#line 268 "grammar.y" + { + d_d(); /* show dictionary/stack pointers */ + } + break; + + case 13: +#line 271 "grammar.y" + { /* show a dictionary location */ + if (stkop((yyvsp[(2) - (2)]))->o_type & OT_INT) { + int idx; + idx = stkop((yyvsp[(2) - (2)]))->o_val.v_i; + eprintf ("%d:\t%d (0%o)\n", idx, stack[idx], + stack[idx]); + } else + eprintf ("usage: D_PEEK \n"); + } + break; + + case 14: +#line 280 "grammar.y" + { + d_stack (pc, 0); /* show compiled code */ + } + break; + + case 15: +#line 287 "grammar.y" + { + /* Check for required params. + */ + if (!errcnt) + proc_params(n_procpar); + } + break; + + case 16: +#line 295 "grammar.y" + { + /* Initialize parser for procedure body. + */ + if (cldebug) + eprintf ("parse init (script_body)...\n"); +ready_(); + + errcnt = 0; + err_cmdblk = 0; + dobkg = 0; + inarglist = 0; + parenlevel = 0; + dobrace = 0; + bracelevel = PBRACE; /* disable lexmodes; force "end" */ + tbrace = 0; + do_params = NO; + last_parm = NULL; + ifseen = NULL; + label1 = NULL; + parse_pfile= currentask->t_pfp; + } + break; + + case 18: +#line 321 "grammar.y" + { + /* Initialize parser for procedure parameters. + */ + if (cldebug) + eprintf ("parse init (proc_stmt)...\n"); + + errcnt = 0; + err_cmdblk = 0; + dobkg = 0; + inarglist = 0; + parenlevel = 0; + bracelevel = PBRACE; + tbrace = 0; + dobrace = 0; + do_params = YES; + last_parm = NULL; + label1 = NULL; + } + break; + + case 20: +#line 343 "grammar.y" + { + n_procpar = 0; + } + break; + + case 22: +#line 352 "grammar.y" + { + n_procpar = 0; + } + break; + + case 24: +#line 358 "grammar.y" + { + n_procpar = 1; + if (!errcnt) + push (stkop((yyvsp[(1) - (1)]))); + } + break; + + case 25: +#line 363 "grammar.y" + { + n_procpar++; + if (!errcnt) + push (stkop((yyvsp[(3) - (3)]))); + } + break; + + case 32: +#line 380 "grammar.y" + { + /* This catches errors in the parameter declarations + * of a procedure script. + */ + yyerrok; + + /* Discard everything and compile a null statement. + */ + if (!errcnt) { + do_params = YES; + pc = currentask->t_bascode; + if (parse_state != PARSE_PARAMS) + compile (END); + + topd = currentask->t_topd; + topcs = currentask->t_topcs; + + /* Unlink any added parms. Resetting of topd will + * already have reclaimed space. + */ + if (last_parm) { + last_parm->p_np = NULL; + currentask->t_pfp->pf_lastpp = last_parm; + last_parm = NULL; + } + } + + /* Print cmdblk and show position of error. We know + * we're parsing a procedure script, so print the line + * number too. + */ + p_position(); + cl_error (E_UERR, "syntax error, line %d", + currentask->t_scriptln); + } + break; + + case 33: +#line 417 "grammar.y" + { + /* For in-line definitions we don't want + * to freeze stuff on the dictionary, so + * only allow additions if the dictionary + * is the same as at the beginning of the task. + */ + if (!errcnt) { + if (parse_state != PARSE_PARAMS) { + if (currentask->t_topd != topd) + cl_error (E_UERR, illegalvar); + last_parm = currentask->t_pfp->pf_lastpp; + } + } + + /* Increment bracelevel temporarily to defeat command + * mode, in case this is an in-line declaration and + * lexmodes=yes. + */ + bracelevel += PBRACE; + tbrace++; + + } + break; + + case 34: +#line 438 "grammar.y" + { + /* Update dictionary to include these definitions. + */ + if (!errcnt) { + if (parse_state != PARSE_PARAMS) { + currentask->t_topd = topd; + last_parm = 0; + } + } + + /* Restore command mode */ + bracelevel -= PBRACE; + tbrace--; + } + break; + + case 35: +#line 454 "grammar.y" + { vartype = V_BOOL; } + break; + + case 36: +#line 455 "grammar.y" + { vartype = V_STRING; } + break; + + case 37: +#line 456 "grammar.y" + { vartype = V_REAL; } + break; + + case 38: +#line 457 "grammar.y" + { vartype = V_FILE; } + break; + + case 39: +#line 458 "grammar.y" + { vartype = V_GCUR; } + break; + + case 40: +#line 459 "grammar.y" + { vartype = V_IMCUR; } + break; + + case 41: +#line 460 "grammar.y" + { vartype = V_UKEY; } + break; + + case 42: +#line 461 "grammar.y" + { vartype = V_PSET; } + break; + + case 43: +#line 462 "grammar.y" + { vartype = V_INT; } + break; + + case 44: +#line 463 "grammar.y" + { vartype = V_STRUCT; } + break; + + case 47: +#line 470 "grammar.y" + { + if (!errcnt) { + if (pp != NULL) { + if (n_aval > 1) + pp->p_type |= PT_ARRAY; + + if (pp->p_type & PT_ARRAY) + do_arrayinit (pp, n_aval, index_cnt); + else + do_scalarinit (pp, inited); + } + } + } + break; + + case 48: +#line 488 "grammar.y" + { + if (!errcnt) { + if (pp != NULL) { + if (!do_params) + cl_error (E_UERR, badparm, pp->p_name); + + if (n_aval > 1) + pp->p_type |= PT_ARRAY; + + if (pp->p_type & PT_ARRAY) + do_arrayinit (pp, n_aval, index_cnt); + else + do_scalarinit (pp, n_aval); + } + } + } + break; + + case 49: +#line 506 "grammar.y" + { + inited = NO; + n_aval = 0; + } + break; + + case 50: +#line 510 "grammar.y" + { + n_aval = 0; + } + break; + + case 51: +#line 513 "grammar.y" + { + inited = YES; + } + break; + + case 52: +#line 518 "grammar.y" + { + index_cnt = 0; + if (!errcnt) + pp = initparam (stkop((yyvsp[(1) - (1)])), do_params, vartype, varlist); + } + break; + + case 53: +#line 523 "grammar.y" + { + int itemp; + + if (!errcnt) { + pp = initparam (stkop((yyvsp[(1) - (1)])), do_params, vartype, varlist); + + if (pp != NULL) { + itemp = (pp->p_type & OT_BASIC) == pp->p_type; + itemp = itemp && !varlist; + if (itemp) + pp->p_type |= PT_ARRAY; + else + cl_error (E_UERR, inval_arr, pp->p_name); + } + } + } + break; + + case 55: +#line 542 "grammar.y" + { + varlist = NO; + index_cnt = 0; + } + break; + + case 56: +#line 546 "grammar.y" + { + if (!do_params) { + eprintf (locallist); + EYYERROR; + } + varlist = YES; + index_cnt = 0; + (yyval) = (yyvsp[(2) - (2)]); + } + break; + + case 60: +#line 566 "grammar.y" + { + if (!errcnt) { + if (pp != NULL) { + if (stkop((yyvsp[(1) - (1)]))->o_type == OT_INT) { + push (stkop((yyvsp[(1) - (1)]))->o_val.v_i); + push (1); + } else if (maybeindex) { + /* Confusion between sexagesimal and index + * range. Maybeindex is set only when operand + * is real. + */ + int i1,i2; + sexa_to_index (stkop((yyvsp[(1) - (1)]))->o_val.v_r, &i1, &i2); + push (i2-i1+1); + push (i1); + } else { + eprintf (inv_index, pp->p_name); + EYYERROR; + } + index_cnt++; + } + } + } + break; + + case 61: +#line 589 "grammar.y" + { + if (!errcnt) { + if (pp != NULL) { + if (stkop((yyvsp[(1) - (3)]))->o_type != OT_INT || + stkop((yyvsp[(3) - (3)]))->o_type != OT_INT) + cl_error (E_UERR, inv_index, pp->p_name); + else { + push (stkop((yyvsp[(3) - (3)]))->o_val.v_i - + stkop((yyvsp[(1) - (3)]))->o_val.v_i + 1); + push (stkop((yyvsp[(1) - (3)]))->o_val.v_i); + } + index_cnt++; + } + } + } + break; + + case 64: +#line 610 "grammar.y" + { + if (!errcnt) { + if (pp != NULL) { + push (stkop((yyvsp[(1) - (1)])) ); + n_aval++; + } + } + } + break; + + case 65: +#line 619 "grammar.y" + { + int cnt; + + if (!errcnt) + if (pp != NULL) { + if (stkop((yyvsp[(1) - (4)]))->o_type != OT_INT) + cl_error (E_UERR, arrdeferr, pp->p_name); + + cnt = stkop((yyvsp[(1) - (4)]))->o_val.v_i; + if (cnt <= 0) + cl_error (E_UERR, arrdeferr, pp->p_name); + + while (cnt-- > 0) { + push (stkop((yyvsp[(3) - (4)]))); + n_aval++; + } + } + } + break; + + case 68: +#line 646 "grammar.y" + { + if (stkop((yyvsp[(2) - (2)]))->o_type == OT_INT) { + stkop((yyvsp[(2) - (2)]))->o_val.v_i *= (yyvsp[(1) - (2)]); + (yyval) = (yyvsp[(2) - (2)]); + } else if (stkop((yyvsp[(2) - (2)]))->o_type == OT_REAL) { + stkop((yyvsp[(2) - (2)]))->o_val.v_r *= (yyvsp[(1) - (2)]); + (yyval) = (yyvsp[(2) - (2)]); + } else { + eprintf ("Invalid constant in declaration.\n"); + EYYERROR; + } + } + break; + + case 69: +#line 660 "grammar.y" + { (yyval) = 1; } + break; + + case 70: +#line 661 "grammar.y" + { (yyval) = -1; } + break; + + case 71: +#line 663 "grammar.y" + { + /* Check if we already had an initialization. + */ + if (!errcnt) { + if (inited && pp != NULL) { + eprintf (twoinits, pp->p_name); + EYYERROR; + } + } + } + break; + + case 72: +#line 673 "grammar.y" + { + if (!errcnt) { + if (inited && pp != NULL) { + eprintf (twoinits, pp->p_name); + EYYERROR; + } + } + } + break; + + case 76: +#line 688 "grammar.y" + { + if (!errcnt) + if (pp != NULL) + do_option (pp, stkop((yyvsp[(1) - (3)])), stkop((yyvsp[(3) - (3)]))); + } + break; + + case 79: +#line 704 "grammar.y" + { + if (!errcnt) + compile (PUSHPARAM, stkop((yyvsp[(1) - (1)]))->o_val.v_s); + } + break; + + case 81: +#line 718 "grammar.y" + { + if (!errcnt) + compile (PUSHCONST, stkop((yyvsp[(1) - (1)]))); + } + break; + + case 82: +#line 722 "grammar.y" + { + /* "gcur" is both a keyword and a CL global parameter, + * and must be built into the grammar here to permit + * reference of the parameter in expressions. + */ + if (!errcnt) + compile (PUSHPARAM, "gcur"); + } + break; + + case 83: +#line 730 "grammar.y" + { + if (!errcnt) + compile (PUSHPARAM, "imcur"); + } + break; + + case 84: +#line 734 "grammar.y" + { + if (!errcnt) + compile (PUSHPARAM, "ukey"); + } + break; + + case 85: +#line 738 "grammar.y" + { + if (!errcnt) + compile (PUSHPARAM, "pset"); + } + break; + + case 87: +#line 746 "grammar.y" + { + if (!errcnt) + compile (ADD); + } + break; + + case 88: +#line 750 "grammar.y" + { + if (!errcnt) + compile (SUB); + } + break; + + case 89: +#line 754 "grammar.y" + { + if (!errcnt) + compile (MUL); + } + break; + + case 90: +#line 758 "grammar.y" + { + if (!errcnt) + compile (DIV); + } + break; + + case 91: +#line 762 "grammar.y" + { + if (!errcnt) + compile (POW); + } + break; + + case 92: +#line 766 "grammar.y" + { + struct operand o; + if (!errcnt) { + o.o_type = OT_INT; + o.o_val.v_i = 2; + compile (PUSHCONST, &o); + compile (INTRINSIC, "mod"); + } + } + break; + + case 93: +#line 775 "grammar.y" + { + if (!errcnt) + compile (CONCAT); + } + break; + + case 94: +#line 779 "grammar.y" + { + if (!errcnt) + compile (LT); + } + break; + + case 95: +#line 783 "grammar.y" + { + if (!errcnt) + compile (GT); + } + break; + + case 96: +#line 787 "grammar.y" + { + if (!errcnt) + compile (LE); + } + break; + + case 97: +#line 791 "grammar.y" + { + if (!errcnt) + compile (GE); + } + break; + + case 98: +#line 795 "grammar.y" + { + if (!errcnt) + compile (EQ); + } + break; + + case 99: +#line 799 "grammar.y" + { + if (!errcnt) + compile (NE); + } + break; + + case 100: +#line 803 "grammar.y" + { + if (!errcnt) + compile (OR); + } + break; + + case 101: +#line 807 "grammar.y" + { + if (!errcnt) + compile (AND); + } + break; + + case 102: +#line 811 "grammar.y" + { + if (!errcnt) + compile (NOT); + } + break; + + case 103: +#line 815 "grammar.y" + { + if (!errcnt) + compile (CHSIGN); + } + break; + + case 104: +#line 820 "grammar.y" + { + /* Free format scan. */ + if (!errcnt) + push (0); /* use control stack to count args */ + } + break; + + case 105: +#line 824 "grammar.y" + { + if (!errcnt) { + struct operand o; + o.o_type = OT_INT; + o.o_val.v_i = pop(); /* get total number of args*/ + compile (PUSHCONST, &o); + compile (SCAN); + } + } + break; + + case 106: +#line 833 "grammar.y" + { + /* Formatted scan. */ + if (!errcnt) + push (0); /* use control stack to count args */ + } + break; + + case 107: +#line 837 "grammar.y" + { + if (!errcnt) { + struct operand o; + + /* Compile number of arguments. */ + o.o_type = OT_INT; + o.o_val.v_i = pop(); + compile (PUSHCONST, &o); + + compile (SCANF); + } + } + break; + + case 108: +#line 850 "grammar.y" + { + /* Free format scan from a parameter. */ + if (!errcnt) + push (0); /* use control stack to count args */ + } + break; + + case 109: +#line 854 "grammar.y" + { + if (!errcnt) { + struct operand o; + o.o_type = OT_INT; + o.o_val.v_i = pop(); /* get total number of args*/ + compile (PUSHCONST, &o); + compile (FSCAN); + } + } + break; + + case 110: +#line 864 "grammar.y" + { + /* Formatted scan from a parameter. + * fscanf (param, format, arg1, ...) + */ + if (!errcnt) { + compile (PUSHCONST, stkop ((yyvsp[(3) - (4)]))); + push (1); /* use control stack to count args */ + } + } + break; + + case 111: +#line 872 "grammar.y" + { + if (!errcnt) { + struct operand o; + + /* Compile number of arguments. */ + o.o_type = OT_INT; + o.o_val.v_i = pop(); + compile (PUSHCONST, &o); + + compile (FSCANF); + } + } + break; + + case 112: +#line 885 "grammar.y" + { + if (!errcnt) + push (0); /* use control stack to count args */ + } + break; + + case 113: +#line 888 "grammar.y" + { + if (!errcnt) { + struct operand o; + o.o_type = OT_INT; + o.o_val.v_i = pop(); + compile (PUSHCONST, &o); + compile (INTRINSIC, stkop((yyvsp[(1) - (5)]))->o_val.v_s); + } + } + break; + + case 115: +#line 903 "grammar.y" + { + /* The YACC value of this must match normal intrinsics + * so we must generate an operand with the proper + * string. + */ + if (!errcnt) + (yyval) = addconst ("int", OT_STRING); + } + break; + + case 116: +#line 911 "grammar.y" + { + if (!errcnt) + (yyval) = addconst ("real", OT_STRING); + } + break; + + case 117: +#line 917 "grammar.y" + { + if (!errcnt) { + push (pop() + 1); /* inc num args */ + } + } + break; + + case 119: +#line 930 "grammar.y" + { + if (!errcnt) { + compile (PUSHCONST, stkop ((yyvsp[(1) - (1)]))); + push (pop() + 1); /* inc num args */ + } + } + break; + + case 120: +#line 936 "grammar.y" + { + if (!errcnt) { + compile (PUSHCONST, stkop ((yyvsp[(1) - (3)]))); + push (pop() + 1); /* inc num args */ + } + } + break; + + case 122: +#line 947 "grammar.y" + { + if (!errcnt) + push (pop() + 1); /* inc num args */ + } + break; + + case 123: +#line 951 "grammar.y" + { + if (!errcnt) + push (pop() + 1); /* inc num args */ + } + break; + + case 146: +#line 989 "grammar.y" + { + bracelevel++; + } + break; + + case 147: +#line 991 "grammar.y" + { + --bracelevel; + } + break; + + case 151: +#line 1003 "grammar.y" + { + --parenlevel; + if (!errcnt) + compile (ASSIGN, stkop((yyvsp[(1) - (3)]))->o_val.v_s); + } + break; + + case 152: +#line 1008 "grammar.y" + { + /* Old code pushed a constant rather than a param + * when not within braces. This doesn't seem + * to be what most people want. + */ + --parenlevel; + if (!errcnt) { + compile (PUSHPARAM, stkop((yyvsp[(3) - (3)]))->o_val.v_s); + compile (ASSIGN, stkop((yyvsp[(1) - (3)]))->o_val.v_s); + } + } + break; + + case 153: +#line 1019 "grammar.y" + { + parenlevel++; + } + break; + + case 154: +#line 1022 "grammar.y" + { + --parenlevel; + if (!errcnt) + compile ((yyvsp[(3) - (4)]), stkop((yyvsp[(1) - (4)]))->o_val.v_s); + } + break; + + case 155: +#line 1031 "grammar.y" + { + parenlevel++; + } + break; + + case 156: +#line 1036 "grammar.y" + { (yyval) = ADDASSIGN; } + break; + + case 157: +#line 1037 "grammar.y" + { (yyval) = SUBASSIGN; } + break; + + case 158: +#line 1038 "grammar.y" + { (yyval) = MULASSIGN; } + break; + + case 159: +#line 1039 "grammar.y" + { (yyval) = DIVASSIGN; } + break; + + case 160: +#line 1040 "grammar.y" + { (yyval) = CATASSIGN; } + break; + + case 161: +#line 1043 "grammar.y" + { + npipes = 0; + } + break; + + case 162: +#line 1045 "grammar.y" + { + if (!errcnt) { + compile (EXEC); + if (npipes > 0) + compile (RMPIPES, npipes); + } + } + break; + + case 164: +#line 1055 "grammar.y" + { + /* Pipefiles must be allocated at run time using a stack + * to permit pipe commands within loops, and to permit + * scripts called in a pipe to themselves contain pipe + * commands. ADDPIPE allocates a new pipefile on the + * pipe stack and pushes its name on the operand stack. + * GETPIPE pushes the pipefile at the top of the pipe + * stack onto the operand stack. RMPIPES removes N pipes + * from the pipe stack, and deletes the physical pipefiles. + */ + + if (!newstdout) { + /* When the runtime code creates the pipe it needs to + * know the identity of the two tasks sharing the pipe + * to determine what type of pipe to create (text or + * binary). Save the pc of the ADDPIPE instruction + * so that we can backpatch it below with a pointer to + * the name of the second task in the pipe (ADDPIPE + * will be called during startup of the first task + * hence will know its name). + */ + pipe_pc = compile (ADDPIPE, NULL); + + if ((yyvsp[(2) - (2)]) == 1) + compile (REDIR); + else + compile (ALLREDIR); + compile (EXEC); + + } else { + eprintf ("multiple redirection\n"); + YYERROR; + } + + } + break; + + case 165: +#line 1089 "grammar.y" + { + /* Compile the GETPIPE instruction with the name of the + * second task in the current pipe, and backpatch the + * matching ADDPIPE instruction with the PC of the GETPIPE. + */ + (coderef(pipe_pc))->c_args = compile (GETPIPE, curr_task); + compile (REDIRIN); + npipes++; /* Overflow checking is in ADDPIPE */ + } + break; + + case 166: +#line 1100 "grammar.y" + { + (yyval) = 1; + } + break; + + case 167: +#line 1103 "grammar.y" + { + (yyval) = 2; + } + break; + + case 168: +#line 1108 "grammar.y" + { + char *ltname; + + ltname = stkop((yyvsp[(1) - (1)]))->o_val.v_s; + compile (CALL, ltname); + strcpy (curr_task, ltname); + + /* The FPRINT task is special; the first arg + * is the destination and must be compiled as + * a string constant no matter what. Set flag + * so that 'arg' compiles PUSHCONST. + */ + printstmt = (strcmp (ltname, "fprint") == 0); + + /* Ditto with SCAN; all the arguments are call by + * reference and must be compiled as string constants. + */ + scanstmt = (strcmp (ltname, "scan") == 0 || + strcmp (ltname, "scanf") == 0); + + absmode = 0; + posit = 0; + newstdout = 0; + parenlevel = 0; + } + break; + + case 169: +#line 1132 "grammar.y" + { + inarglist = 1; + } + break; + + case 170: +#line 1134 "grammar.y" + { + inarglist = 0; + parenlevel = 0; + scanstmt = 0; + } + break; + + case 171: +#line 1141 "grammar.y" + { + /* (,x) equates to nargs == 2. Call posargset with + * negative dummy argument to bump nargs. + */ + if (!errcnt) { + compile (POSARGSET, -1); + posit++; + printstmt = 0; + scanstmt = 0; + } + } + break; + + case 176: +#line 1160 "grammar.y" + { + if (!errcnt) { + if (posit > 0) { /* not first time */ + compile (POSARGSET, -posit); + printstmt = 0; + scanstmt = 0; + } + posit++; + } + } + break; + + case 177: +#line 1170 "grammar.y" + { + if (absmode) { + eprintf (posfirst); + EYYERROR; + } else + if (!errcnt) + compile (POSARGSET, posit++); + } + break; + + case 178: +#line 1178 "grammar.y" + { + if (absmode) { + eprintf (posfirst); + EYYERROR; + } else if (!errcnt) { + if (scanstmt) { + char pname[SZ_FNAME]; + char *pk, *t, *p, *f; + struct pfile *pfp; + struct operand o; + + /* If no task name specified check the pfile for + * the task containing the scan statement for the + * named parameter. + */ + breakout (stkop((yyvsp[(1) - (1)]))->o_val.v_s, &pk, &t, &p, &f); + pfp = currentask->t_pfp; + if (*pk == NULL && *t == NULL && + pfp && paramfind(pfp,p,0,1)) { + + sprintf (pname, "%s.%s", + currentask->t_ltp->lt_lname, p); + if (*f) { + strcat (pname, "."); + strcat (pname, f); + } + } else + strcpy (pname, stkop((yyvsp[(1) - (1)]))->o_val.v_s); + + o = *(stkop((yyvsp[(1) - (1)]))); + o.o_val.v_s = pname; + compile (PUSHCONST, &o); + compile (INDIRPOSSET, posit++); + + } else if (parenlevel == 0 || printstmt) { + compile (PUSHCONST, stkop((yyvsp[(1) - (1)]))); + compile (INDIRPOSSET, posit++); + /* only first arg of fprint stmt is special. */ + printstmt = 0; + + } else { + compile (PUSHPARAM, stkop((yyvsp[(1) - (1)]))->o_val.v_s); + compile (POSARGSET, posit++); + } + } + } + break; + + case 179: +#line 1224 "grammar.y" + { + absmode++; + if (!errcnt) + compile (ABSARGSET, stkop((yyvsp[(1) - (3)]))->o_val.v_s); + } + break; + + case 180: +#line 1229 "grammar.y" + { + absmode++; + if (!errcnt) { + if (parenlevel == 0) { + compile (PUSHCONST, stkop((yyvsp[(3) - (3)]))); + compile (INDIRABSSET, stkop((yyvsp[(1) - (3)]))->o_val.v_s); + } else { + compile (PUSHPARAM, stkop((yyvsp[(3) - (3)]))->o_val.v_s); + compile (ABSARGSET, stkop((yyvsp[(1) - (3)]))->o_val.v_s); + } + } + } + break; + + case 181: +#line 1241 "grammar.y" + { + absmode++; + if (!errcnt) + compile (SWON, stkop((yyvsp[(1) - (2)]))->o_val.v_s); + } + break; + + case 182: +#line 1246 "grammar.y" + { + absmode++; + if (!errcnt) + compile (SWOFF, stkop((yyvsp[(1) - (2)]))->o_val.v_s); + } + break; + + case 183: +#line 1251 "grammar.y" + { + if (!errcnt) + compile (REDIRIN); + } + break; + + case 184: +#line 1255 "grammar.y" + { + newstdout++; + if (!errcnt) + compile (REDIR); + } + break; + + case 185: +#line 1260 "grammar.y" + { + newstdout++; + if (!errcnt) + compile (ALLREDIR); + } + break; + + case 186: +#line 1265 "grammar.y" + { + newstdout++; + if (!errcnt) + compile (APPENDOUT); + } + break; + + case 187: +#line 1270 "grammar.y" + { + newstdout++; + if (!errcnt) + compile (ALLAPPEND); + } + break; + + case 188: +#line 1275 "grammar.y" + { + if (!errcnt) + compile (GSREDIR, stkop((yyvsp[(1) - (2)]))->o_val.v_s); + } + break; + + case 189: +#line 1281 "grammar.y" + { + absmode++; + /* constant already pushed by expr0. + */ + } + break; + + case 190: +#line 1286 "grammar.y" + { + absmode++; + if (!errcnt) { + if (parenlevel == 0) + compile (PUSHCONST, stkop((yyvsp[(1) - (1)]))); + else + compile (PUSHPARAM, stkop((yyvsp[(1) - (1)]))->o_val.v_s); + } + } + break; + + case 191: +#line 1297 "grammar.y" + { + --parenlevel; + if (!errcnt) + compile (IMMED); + } + break; + + case 192: +#line 1302 "grammar.y" + { + --parenlevel; + if (!errcnt) + compile (INSPECT, stkop((yyvsp[(2) - (2)]))->o_val.v_s); + } + break; + + case 193: +#line 1309 "grammar.y" + { + --parenlevel; + if (!errcnt) + compile (INSPECT, stkop((yyvsp[(1) - (2)]))->o_val.v_s); + } + break; + + case 194: +#line 1316 "grammar.y" + { + if (!errcnt) + compile (OSESC, stkop((yyvsp[(1) - (1)]))->o_val.v_s); + } + break; + + case 195: +#line 1322 "grammar.y" + { + --parenlevel; + if (!errcnt) + compile (IMMED); + } + break; + + case 196: +#line 1329 "grammar.y" + { + /* pop BIFF addr and set branch to just after statement + */ + XINT biffaddr; + if (!errcnt) { + biffaddr = pop(); + coderef (biffaddr)->c_args = pc - biffaddr - 3; + } + } + break; + + case 197: +#line 1340 "grammar.y" + { + /* save BIFF addr so branch can be filled in + */ + if (!errcnt) + push (compile (BIFF, 0)); + } + break; + + case 198: +#line 1345 "grammar.y" + { + /* The shift/reduce conflict in the IF-IF/ELSE + * construct can cause errors in compilation + * because the IF statement can also be a + * terminal symbol, i.e. it may be all that + * is parsed in one call to the parser. + * The parser must look ahead one token + * to find if there is an else statement + * following. If there is no following + * token an EOF may be detected prematurely. + * When the IF statement is being parsed not + * inside any braces, then when the next token + * is not an ELSE care must be taken that this + * token is seen on a subsequent invocation + * of the parser. The `ifseen' flag is + * used within the support for the lexical + * analyzer located in `history.c'. + */ + if (cldebug) + eprintf ("ytab: setting ifseen=yes\n"); + + if (currentask->t_flags & T_INTERACTIVE) + ifseen = ip_cmdblk; + else + ifseen = cmdblk; + } + break; + + case 199: +#line 1373 "grammar.y" + { + XINT biffaddr; + + ifseen = NULL; + if (!errcnt) { + /* Pop and save BIFF address, compile and push addr + * of GOTO, and set BIFF branch to just after GOTO. + */ + biffaddr = pop(); + push (compile (GOTO, 0)); + coderef (biffaddr)->c_args = pc - biffaddr - 3; + } + } + break; + + case 200: +#line 1385 "grammar.y" + { + XINT gotoaddr; + if (!errcnt) { + /* Pop GOTO addr and set branch to just after statement + */ + gotoaddr = pop(); + coderef (gotoaddr)->c_args = pc - gotoaddr - 3; + } + } + break; + + case 201: +#line 1396 "grammar.y" + { + /* Save starting addr of while expression. + */ + if (!errcnt) { + push (pc); + loopincr(); + } + } + break; + + case 202: +#line 1403 "grammar.y" + { + /* Save BIFF addr so branch can be filled in. + */ + if (!errcnt) + push (compile (BIFF, 0)); + } + break; + + case 203: +#line 1408 "grammar.y" + { + XINT biffaddr; + + if (!errcnt) { + /* Pop and save addr of BIFF instruction. */ + biffaddr = pop(); + /* Pop addr of expression and build a goto there. */ + compile (GOTO, pop() - pc - 3); + /* Now can set BIFF branch to just after statement.*/ + coderef (biffaddr)->c_args = pc - biffaddr - 3; + loopdecr(); + } + } + break; + + case 204: +#line 1441 "grammar.y" + { + if (!errcnt) + push(pc); /* Loop1: */ + } + break; + + case 205: +#line 1445 "grammar.y" + { + if (!errcnt) { + if (for_expr) + ppush (compile(BIFF, 0)); /* if (!e2) */ + + /* Add 3 to skip following GOTO. + */ + ppush (pc+3); /* Loop2: */ + ppush (compile(GOTO,0)); /* goto Loop3 */ + + /* Save current location as the destination + * for NEXT statements. + */ + loopincr(); + } + } + break; + + case 206: +#line 1461 "grammar.y" + { + XINT stmtaddr; + + if (!errcnt) { + stmtaddr = pop(); + compile (GOTO, stmtaddr-pc-3); /* Goto loop1 */ + stmtaddr = pop(); + coderef(stmtaddr)->c_args = pc - stmtaddr - 3; + } + } + break; + + case 207: +#line 1471 "grammar.y" + { + XINT stmtaddr; + + if (!errcnt) { + stmtaddr = pop(); + compile (GOTO, stmtaddr-pc-3); /* goto loop2 */ + + if (for_expr) { + stmtaddr = pop(); + coderef(stmtaddr)->c_args = pc - stmtaddr - 3; + } + loopdecr(); + } + } + break; + + case 210: +#line 1494 "grammar.y" + { + for_expr = YES; + } + break; + + case 211: +#line 1497 "grammar.y" + { + for_expr = NO; + } + break; + + case 212: +#line 1523 "grammar.y" + { + if (!errcnt) { + push (compile(SWITCH)); + + /* Compile GOTO which will branch past end of + * switch. This is needed if there is no DEFAULT. + */ + compile (GOTO, 0); + } + } + break; + + case 213: +#line 1532 "grammar.y" + { + /* Set up jumptable and pop space on stack. + */ + if (!errcnt) + setswitch(); + } + break; + + case 214: +#line 1540 "grammar.y" + { + if (!errcnt) { + ncaseval = 0; + if (!in_switch()) { + eprintf ("Improper CASE statement.\n"); + EYYERROR; + } + } + } + break; + + case 215: +#line 1548 "grammar.y" + { + XINT pcase; + + if (!errcnt) { + pcase = compile (CASE, ncaseval); + + /* Fill in argument list. + */ + caseset (&(coderef(pcase)->c_args), ncaseval); + push (pcase); + } + } + break; + + case 216: +#line 1559 "grammar.y" + { + /* Branch to end of switch block + */ + if (!errcnt) + push (compile(GOTO, 0)); + } + break; + + case 217: +#line 1567 "grammar.y" + { + /* Compile an operand to store the current PC. + */ + if (!errcnt) { + if (!in_switch()) { + eprintf ("Improper DEFAULT statement.\n"); + EYYERROR; + } + push (compile(DEFAULT)); + } + } + break; + + case 218: +#line 1577 "grammar.y" + { + /* Branch past jump table. + */ + if (!errcnt) + push (compile(GOTO, 0)); + } + break; + + case 219: +#line 1585 "grammar.y" + { + /* All NEXT statements are backward references, + * so we simply store the addresses in an array. + */ + if (!errcnt) { + if (nestlevel) + compile (GOTO, nextdest[nestlevel-1]-pc-3); + else { + eprintf ( "NEXT outside of loop.\n"); + EYYERROR; + } + } + } + break; + + case 220: +#line 1600 "grammar.y" + { + /* Each BREAK is a forward reference. For the + * first BREAK in each loop we compile a + * GOTO statement which will be the object of + * all BREAK statements within the loop. When + * the loop is terminated the target of this + * GOTO will be set. + */ + int dest; + + if (!errcnt) { + if (!nestlevel) { + eprintf ("Break outside of loop.\n"); + EYYERROR; + } else if ((dest = brkdest[nestlevel-1]) != 0) + compile (GOTO, dest-pc-3); + else { + brkdest[nestlevel-1] = pc; + compile (GOTO, 0); + } + } + } + break; + + case 221: +#line 1624 "grammar.y" + { + if (!errcnt) + compile (END); + } + break; + + case 222: +#line 1628 "grammar.y" + { + /* Return values currently not implemented. + */ + eprintf ("Warning: return value ignored.\n"); + if (!errcnt) + compile (END); + } + break; + + case 223: +#line 1640 "grammar.y" + { + bracelevel -= PBRACE; + if (bracelevel < 0) { + eprintf ("Too few left braces.\n"); + EYYERROR; + } else if (bracelevel > 0) { + eprintf ("Too few right braces.\n"); + EYYERROR; + } + } + break; + + case 224: +#line 1652 "grammar.y" + { + /* Put symbol in table in dictionary and + * process indirect references if present. + */ + struct label *l; + + if (!errcnt) { + l = getlabel (stkop((yyvsp[(1) - (3)]))); + + if (l == NULL) { + l = setlabel (stkop((yyvsp[(1) - (3)]))); + l->l_loc = pc; + } else if (l->l_defined) { + eprintf ("Identical labels.\n"); + EYYERROR; + } else { + /* Get this GOTO out of the + * indirect list so we can use + * the argument as the destination + */ + XINT gotopc; + gotopc = l->l_loc; + unsetigoto (gotopc); + + /* Fix the indirect reference. + */ + coderef(gotopc)->c_args = pc - gotopc - 3; + } + (l->l_defined)++; + } + } + break; + + case 226: +#line 1686 "grammar.y" + { + /* Get the address corresponding to the label. + */ + struct label *l; + + if (!errcnt) { + l = getlabel (stkop((yyvsp[(2) - (2)]))); + + if (l != NULL) + compile (GOTO, l->l_loc - pc - 3); + else { + /* Ready for indirect GOTO + */ + l = setlabel (stkop((yyvsp[(2) - (2)]))); + l->l_loc = pc; + setigoto (compile(GOTO, 0)); + l->l_defined = 0; + } + } + } + break; + + case 229: +#line 1716 "grammar.y" + { + /* Save pc before compiling statement for loop back + */ + stmt_pc = pc; + n_oarr = 0; + i_oarr = 0; + ifseen = NULL; + } + break; + + case 230: +#line 1724 "grammar.y" + { + /* If there was an open reference compile the + * loop increment and goback. + */ + XINT push_pc; + + if (!errcnt) { + if (n_oarr) { + compile (INDXINCR, stmt_pc-pc-4, 2*n_oarr+1); + + /* We are going to store initialization + * info for the implicit loop here. + * It is loopincr's responsibility to + * branch around it. This data is what + * should be pointed to by the special + * PUSHINDEX compiled at the first open + * array reference. + */ + push_pc = pop(); /* Location of PUSHINDEX */ + coderef(push_pc)->c_args = pc - push_pc - 3; + + stack[pc++] = n_oarr; + for (i_oarr=0; i_oarrt_bascode; + if (parse_state != PARSE_PARAMS) + compile (END); + + topd = currentask->t_topd; + topcs = currentask->t_topcs; + + /* Unlink any added parms. Resetting of topd will + * already have reclaimed space. + */ + if (last_parm) { + last_parm->p_np = NULL; + currentask->t_pfp->pf_lastpp = last_parm; + last_parm = NULL; + } + } + + /* Tell user about the syntax error, printing the + * offending line and position if possible. + */ + if (currentask->t_flags & T_SCRIPT) + eprintf ("** Syntax error, line %d\n", + currentask->t_scriptln); + else + eprintf ("** Syntax error\n"); + p_position(); + + if (!(currentask->t_flags & T_SCRIPT)) { + /* If interactive, we're finished if not within braces. + */ + if (!bracelevel) + YYACCEPT; + } + + /* Note that we do not call cl_error() here to abort, but + * continue on parsing the script for more syntax errors. + */ + if (++errcnt > MAX_ERR) + cl_error (E_UERR, "Too many syntax errors."); + } + break; + + case 235: +#line 1823 "grammar.y" + { + if (!errcnt) { + push(stkop((yyvsp[(1) - (1)]))) ; + ncaseval++; + } + } + break; + + case 238: +#line 1843 "grammar.y" + { + int dim, d, i1, i2, mode; + + /* In command arguments, when not in parentheses + * we just pass the param as a string constant. + */ + if (!errcnt) { + lastref = NO; + if (!inarglist || parenlevel) { + i_oarr = 0; + index_cnt = 0; + + strncpy (curr_param, stkop((yyvsp[(1) - (1)]))->o_val.v_s, + SZ_FNAME); + + /* If a '.' is found in the name we have a + * reference to an external task, or to a + * specific field. In these cases we don't + * want implicit looping. + */ + if (index (curr_param, '.') == NULL) { + if ((dim = get_dim (curr_param)) > 0) { + lastref = YES; + for (d = 0; d < dim; d++) { + getlimits (curr_param, d, &i1, &i2); + mode = make_imloop (i1, i2); + if (mode) + compile (PUSHINDEX, -1); + else + push (compile(PUSHINDEX, 0)); + } + n_oarr = dim; + } + } + } + } + } + break; + + case 239: +#line 1880 "grammar.y" + { + if (!errcnt) { + strncpy (curr_param, stkop((yyvsp[(1) - (1)]))->o_val.v_s, SZ_FNAME); + index_cnt = 0; + } + } + break; + + case 240: +#line 1887 "grammar.y" + { + if (i_oarr > 0 && n_oarr == 0) + n_oarr = i_oarr; + i_oarr = 0; + lastref = YES; + } + break; + + case 241: +#line 1895 "grammar.y" + { + index_cnt = 1; + } + break; + + case 242: +#line 1898 "grammar.y" + { + index_cnt++; + } + break; + + case 244: +#line 1904 "grammar.y" + { + if (!errcnt) + compile (PUSHINDEX, 0); + } + break; + + case 245: +#line 1909 "grammar.y" + { + if (!errcnt) { + compile (PUSHPARAM, stkop((yyvsp[(1) - (1)]))->o_val.v_s); + compile (PUSHINDEX, 0); + } + } + break; + + case 246: +#line 1915 "grammar.y" + { + int i1, i2, mode; + + if (!errcnt) { + if (index(curr_param, '.') != NULL) { + eprintf (exlimits); + EYYERROR; + } + if (getlimits (curr_param, index_cnt, &i1, &i2) + == ERR) { + eprintf ("Implicit index error for %s.\n", + curr_param); + EYYERROR; + } + mode = make_imloop (i1, i2); + if (mode) + compile (PUSHINDEX, mode); + else + push (compile (PUSHINDEX, mode)); + } + } + break; + + case 247: +#line 1936 "grammar.y" + { + /* There is an ambiguity in the grammar between + * sexagesimal constants, and array range references. + * Since the sexagesimal constants are recognized + * in the lexical analyzer we can't just change the + * grammar. The kludge around this is to have + * makeop set a flag telling us that the last + * constant it compiled COULD have been an index + * range. We check the flag here and if it is + * set we convert back and compile an implicit loop + * otherwise we just push the constant. + */ + int i1, i2, mode; + + if (!errcnt) { + if (maybeindex) { + sexa_to_index (stkop((yyvsp[(1) - (1)]))->o_val.v_r, &i1, &i2); + mode = make_imloop (i1, i2); + if (mode) + compile (PUSHINDEX, mode); + else + push (compile (PUSHINDEX, mode)); + } else { + compile (PUSHCONST, stkop((yyvsp[(1) - (1)]))); + compile (PUSHINDEX, 0); + } + } + } + break; + + case 248: +#line 1970 "grammar.y" + { + (yyval) = (yyvsp[(1) - (1)]); + } + break; + + case 249: +#line 1975 "grammar.y" + { + (yyval) = (yyvsp[(1) - (1)]); + } + break; + + case 250: +#line 1980 "grammar.y" + { + (yyval) = (yyvsp[(1) - (1)]); + } + break; + + case 252: +#line 1986 "grammar.y" + { + /* If statements are delimited by ';'s, do not execute + * until next newline EOST is received. + */ + sawnl = 0; + } + break; + + case 258: +#line 2008 "grammar.y" + { parenlevel++; } + break; + + case 259: +#line 2011 "grammar.y" + { --parenlevel; } + break; + + case 260: +#line 2014 "grammar.y" + { sawnl = 1; } + break; + + +/* Line 1267 of yacc.c. */ +#line 4294 "y.tab.c" + default: break; + } + YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc); + + YYPOPSTACK (yylen); + yylen = 0; + YY_STACK_PRINT (yyss, yyssp); + + *++yyvsp = yyval; + + + /* Now `shift' the result of the reduction. Determine what state + that goes to, based on the state we popped back to and the rule + number reduced by. */ + + yyn = yyr1[yyn]; + + yystate = yypgoto[yyn - YYNTOKENS] + *yyssp; + if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp) + yystate = yytable[yystate]; + else + yystate = yydefgoto[yyn - YYNTOKENS]; + + goto yynewstate; + + +/*------------------------------------. +| yyerrlab -- here on detecting error | +`------------------------------------*/ +yyerrlab: + /* If not already recovering from an error, report this error. */ + if (!yyerrstatus) + { + ++yynerrs; +#if ! YYERROR_VERBOSE + yyerror (YY_("syntax error")); +#else + { + YYSIZE_T yysize = yysyntax_error (0, yystate, yychar); + if (yymsg_alloc < yysize && yymsg_alloc < YYSTACK_ALLOC_MAXIMUM) + { + YYSIZE_T yyalloc = 2 * yysize; + if (! (yysize <= yyalloc && yyalloc <= YYSTACK_ALLOC_MAXIMUM)) + yyalloc = YYSTACK_ALLOC_MAXIMUM; + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); + yymsg = (char *) YYSTACK_ALLOC (yyalloc); + if (yymsg) + yymsg_alloc = yyalloc; + else + { + yymsg = yymsgbuf; + yymsg_alloc = sizeof yymsgbuf; + } + } + + if (0 < yysize && yysize <= yymsg_alloc) + { + (void) yysyntax_error (yymsg, yystate, yychar); + yyerror (yymsg); + } + else + { + yyerror (YY_("syntax error")); + if (yysize != 0) + goto yyexhaustedlab; + } + } +#endif + } + + + + if (yyerrstatus == 3) + { + /* If just tried and failed to reuse look-ahead token after an + error, discard it. */ + + if (yychar <= YYEOF) + { + /* Return failure if at end of input. */ + if (yychar == YYEOF) + YYABORT; + } + else + { + yydestruct ("Error: discarding", + yytoken, &yylval); + yychar = YYEMPTY; + } + } + + /* Else will try to reuse look-ahead token after shifting the error + token. */ + goto yyerrlab1; + + +/*---------------------------------------------------. +| yyerrorlab -- error raised explicitly by YYERROR. | +`---------------------------------------------------*/ +yyerrorlab: + + /* Pacify compilers like GCC when the user code never invokes + YYERROR and the label yyerrorlab therefore never appears in user + code. */ + if (/*CONSTCOND*/ 0) + goto yyerrorlab; + + /* Do not reclaim the symbols of the rule which action triggered + this YYERROR. */ + YYPOPSTACK (yylen); + yylen = 0; + YY_STACK_PRINT (yyss, yyssp); + yystate = *yyssp; + goto yyerrlab1; + + +/*-------------------------------------------------------------. +| yyerrlab1 -- common code for both syntax error and YYERROR. | +`-------------------------------------------------------------*/ +yyerrlab1: + yyerrstatus = 3; /* Each real token shifted decrements this. */ + + for (;;) + { + yyn = yypact[yystate]; + if (yyn != YYPACT_NINF) + { + yyn += YYTERROR; + if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) + { + yyn = yytable[yyn]; + if (0 < yyn) + break; + } + } + + /* Pop the current state because it cannot handle the error token. */ + if (yyssp == yyss) + YYABORT; + + + yydestruct ("Error: popping", + yystos[yystate], yyvsp); + YYPOPSTACK (1); + yystate = *yyssp; + YY_STACK_PRINT (yyss, yyssp); + } + + if (yyn == YYFINAL) + YYACCEPT; + + *++yyvsp = yylval; + + + /* Shift the error token. */ + YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp); + + yystate = yyn; + goto yynewstate; + + +/*-------------------------------------. +| yyacceptlab -- YYACCEPT comes here. | +`-------------------------------------*/ +yyacceptlab: + yyresult = 0; + goto yyreturn; + +/*-----------------------------------. +| yyabortlab -- YYABORT comes here. | +`-----------------------------------*/ +yyabortlab: + yyresult = 1; + goto yyreturn; + +#ifndef yyoverflow +/*-------------------------------------------------. +| yyexhaustedlab -- memory exhaustion comes here. | +`-------------------------------------------------*/ +yyexhaustedlab: + yyerror (YY_("memory exhausted")); + yyresult = 2; + /* Fall through. */ +#endif + +yyreturn: + if (yychar != YYEOF && yychar != YYEMPTY) + yydestruct ("Cleanup: discarding lookahead", + yytoken, &yylval); + /* Do not reclaim the symbols of the rule which action triggered + this YYABORT or YYACCEPT. */ + YYPOPSTACK (yylen); + YY_STACK_PRINT (yyss, yyssp); + while (yyssp != yyss) + { + yydestruct ("Cleanup: popping", + yystos[*yyssp], yyvsp); + YYPOPSTACK (1); + } +#ifndef yyoverflow + if (yyss != yyssa) + YYSTACK_FREE (yyss); +#endif +#if YYERROR_VERBOSE + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); +#endif + /* Make sure YYID is used. */ + return YYID (yyresult); +} + + +#line 2017 "grammar.y" + + +#include "lexyy.c" +#include "lexicon.c" + diff --git a/pkg/cl/ytab.h b/pkg/cl/ytab.h new file mode 100644 index 00000000..587e26e1 --- /dev/null +++ b/pkg/cl/ytab.h @@ -0,0 +1,165 @@ +/* A Bison parser, made by GNU Bison 2.3. */ + +/* Skeleton interface for Bison's Yacc-like parsers in C + + Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ + +/* As a special exception, you may create a larger work that contains + part or all of the Bison parser skeleton and distribute that work + under terms of your choice, so long as that work isn't itself a + parser generator using the skeleton or a modified version thereof + as a parser skeleton. Alternatively, if you modify or redistribute + the parser skeleton itself, you may (at your option) remove this + special exception, which will cause the skeleton and the resulting + Bison output files to be licensed under the GNU General Public + License without this special exception. + + This special exception was added by the Free Software Foundation in + version 2.2 of Bison. */ + +/* Tokens. */ +#ifndef YYTOKENTYPE +# define YYTOKENTYPE + /* Put the tokens into the symbol table, so that GDB and other debuggers + know about them. */ + enum yytokentype { + Y_SCAN = 258, + Y_SCANF = 259, + Y_FSCAN = 260, + Y_FSCANF = 261, + Y_OSESC = 262, + Y_APPEND = 263, + Y_ALLAPPEND = 264, + Y_ALLREDIR = 265, + Y_GSREDIR = 266, + Y_ALLPIPE = 267, + D_D = 268, + D_PEEK = 269, + Y_NEWLINE = 270, + Y_CONSTANT = 271, + Y_IDENT = 272, + Y_WHILE = 273, + Y_IF = 274, + Y_ELSE = 275, + Y_FOR = 276, + Y_BREAK = 277, + Y_NEXT = 278, + Y_SWITCH = 279, + Y_CASE = 280, + Y_DEFAULT = 281, + Y_RETURN = 282, + Y_GOTO = 283, + Y_PROCEDURE = 284, + Y_BEGIN = 285, + Y_END = 286, + Y_BOOL = 287, + Y_INT = 288, + Y_REAL = 289, + Y_STRING = 290, + Y_FILE = 291, + Y_STRUCT = 292, + Y_GCUR = 293, + Y_IMCUR = 294, + Y_UKEY = 295, + Y_PSET = 296, + YOP_AOCAT = 297, + YOP_AODIV = 298, + YOP_AOMUL = 299, + YOP_AOSUB = 300, + YOP_AOADD = 301, + YOP_OR = 302, + YOP_AND = 303, + YOP_NE = 304, + YOP_EQ = 305, + YOP_GE = 306, + YOP_LE = 307, + YOP_CONCAT = 308, + UMINUS = 309, + YOP_NOT = 310, + YOP_POW = 311 + }; +#endif +/* Tokens. */ +#define Y_SCAN 258 +#define Y_SCANF 259 +#define Y_FSCAN 260 +#define Y_FSCANF 261 +#define Y_OSESC 262 +#define Y_APPEND 263 +#define Y_ALLAPPEND 264 +#define Y_ALLREDIR 265 +#define Y_GSREDIR 266 +#define Y_ALLPIPE 267 +#define D_D 268 +#define D_PEEK 269 +#define Y_NEWLINE 270 +#define Y_CONSTANT 271 +#define Y_IDENT 272 +#define Y_WHILE 273 +#define Y_IF 274 +#define Y_ELSE 275 +#define Y_FOR 276 +#define Y_BREAK 277 +#define Y_NEXT 278 +#define Y_SWITCH 279 +#define Y_CASE 280 +#define Y_DEFAULT 281 +#define Y_RETURN 282 +#define Y_GOTO 283 +#define Y_PROCEDURE 284 +#define Y_BEGIN 285 +#define Y_END 286 +#define Y_BOOL 287 +#define Y_INT 288 +#define Y_REAL 289 +#define Y_STRING 290 +#define Y_FILE 291 +#define Y_STRUCT 292 +#define Y_GCUR 293 +#define Y_IMCUR 294 +#define Y_UKEY 295 +#define Y_PSET 296 +#define YOP_AOCAT 297 +#define YOP_AODIV 298 +#define YOP_AOMUL 299 +#define YOP_AOSUB 300 +#define YOP_AOADD 301 +#define YOP_OR 302 +#define YOP_AND 303 +#define YOP_NE 304 +#define YOP_EQ 305 +#define YOP_GE 306 +#define YOP_LE 307 +#define YOP_CONCAT 308 +#define UMINUS 309 +#define YOP_NOT 310 +#define YOP_POW 311 + + + + +#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED +typedef int YYSTYPE; +# define yystype YYSTYPE /* obsolescent; will be withdrawn */ +# define YYSTYPE_IS_DECLARED 1 +# define YYSTYPE_IS_TRIVIAL 1 +#endif + +extern YYSTYPE yylval; + diff --git a/pkg/dataio/Revisions b/pkg/dataio/Revisions new file mode 100644 index 00000000..2c83227f --- /dev/null +++ b/pkg/dataio/Revisions @@ -0,0 +1,887 @@ +.help revisions Jun88 pkg.dataio +.nf + +dataio$lib/mkpkg + The getdatatype.x and ranges.x files were duplicates of those in the + XTOOLS library which is linked in dataio. These files should be the + versions actually linked in the binary, making XTOOLS unnecessary, but + I think the intent was to use XTOOLS. The getdatatype.x is identical + but there are slight changes in ranges.x. These files were left in + place in case there are problems found but the binary should now be + using the XTOOLS versions. (12/5/08, MJF) + +dataio$import/ipproc.gx + Fixed a type flag being used to determine byte-swapping. (12/5/08, MJF) + +dataio$import/t_import.x + Fixed a type declaration (1/21/08, MJF) + +dataio$export/exraster.gx + Fixed a bug in computing the number of output pixels (1/5/04, MJF) + +dataio$import/ipproc.gx + An operand point was possibly being freed twice, once in the ip_wrline() + procedure and again in the evvfree() call when processing completed. + This could cause a segfault on some system (9/27/02, MJF) + +dataio$export/exraster.gx +dataio$export/bltins/exppm.x + There was a bug in the generation of PPM files when using images with + and odd number of columns causing the line to be too long by one byte. + The output image will now truncate the last column to avoid this since + we cannot write byte data. (8/9/02, MJF) + +dataio$export/export.h + Changed the zscale sampling parameters to use more points spread out + over more of the image. The old values would sometimes find an + innappropriate z1/z2 range causing problems when doing many images in + batch mode. (3/20/02, MJF) + +dataio$fits/t_rfits.x +dataio$imtext/t_rtextimage.x + Changed the clgetc calls to to clgstr calls for the datatype parameter + in rfits and the otype parameter in rtextimage. This change is required + to avoid an "ERROR: Parameter not a legal character constant (parname)" + error introduced by recent changes to the CL. Basically "" is no longer + a legal argument for clgetc. (6/15/01 LED) + +dataio$fits/fits_rheader.x + Fixed a bug in the MEF file reading error recovery code that can cause + a segvio due to a too many open file descriptors condition. (5/1/01 LED) + +dataio$export/bltins/expgm.x +dataio$export/bltins/exppm.x + Fixed a bug in writing the header for these formats on PCIX. (6/23/00 MJF) + +dataio$export.par + Made the 'format' parameter automatic mode (5/16/00 MJF) + +dataio$export/expreproc.x + Modified so that the 'overlay' colors are not scaled. (5/16/00 MJF) + +dataio$reblock/t_reblock.x +dataio$reblock/reblock_file.x + Fixed a bug in the output block writing code caused by a failure to + check the status return of the awaitb call. At the same time worked + around a longstanding problem in tape to tape copies caused by + trying to open and close a magtape file for writing when there is + no data and fixed an initialization bug in the record trimming and + padding code that has been there a long time. (2/9/00 LED) + +dataio$import/ipdb.gx + Fixed a string overflow bug causing segvios on PCs (12/13/99 MJF) + +dataio$import.par +dataio$export.par + Changed query param modes to auto to avoid prompt from epar :go + command. (11/4/99 MJF) + +dataio$export/bltins/exeps.x + Fixed an array overrun when writing EPS trailer comments. (10/25/99 MJF) + +dataio$export/mkpkg +dataio$export/*/mkpkg +dataio$import/mkpkg +dataio$import/*/mkpkg + Fixed missing/extra file dependencies (9/20/99, MJF) + +dataio$export/exrgb8.x + Fixed a bug causing the cmap() function to write a garbage line at the + top or bottom of the output image. (8/20/99 MJF) + +dataio$export/exzscale.x +dataio$import/t_import.x +dataio$import/bltins/ipgif.x + Cleaned up some missing sfree() calls. (7/28/99 MJF) + +dataio$fits/wfits.h +dataio$fits/fits_cards.x +dataio$fits/fits_params.x + Modified wfits to write the DATE keyword value in the new format (including + a time field) and in units of GMT. (5/8/99 LED) + +dataio$export/bltins/exhdr.x + Changed the binary file header to use a 4-digit year (5/5/99, er..1999 MJF)) + +dataio$export/bltins/exras.x +dataio$export/bltins/exxwd.x + Fixed a bug in which rasterfiles and XWD file aren't swapped on LSB + machines when requested by the user. (12/14/98 MJF) + +dataio$import/t_import.x +dataio$import/ipproc.gx + Fixed a bug preventing 1-D data from being converted. (12/10/98 MJF)) + +dataio$import/t_import.x + Modified to initialize the 'use_cmap' flag to on by default so 8-bit + colormap images will be converted correctly. (7/14/98 MJF) + +dataio$fits/fits_cards.x + Added a check for pre-existing IRAFNAME keywords to the wfits task + (6/18/98 LED) + +dataio$export/exzscale.x +dataio$export/t_export.x +dataio$export/exobands.gx +dataio$export/bltins/exeps.x +dataio$export/bltins/exgif.x +dataio$export/bltins/exrgb.x +dataio$export/bltins/exxwd.x + Removed some unused variable and fixed type clashes (3/28/98 MJF) + +dataio$export/expreproc.x + Fixed a bug where the setcmap function was finding the colormap name + incorrectly when '@' params were used in a zscale function (2/2/98 MJF) + +dataio$import/t_import.x +dataio$import/ipobands.gx + Fixed a bug in which use of the red()/green()/blue() functions caused + the size of the output image to be computed incorrectly. (12/12/97 MJF) + +dataio$fits/fits_read.x + Fixed a bug in the header listing code which resulted in rfits reading + through the whole image after listing the data when EXTENSION = N. + (11/3/97 LED) + +dataio$fits/fits_read.x + Fixed a bug in the global header handling code that could result a + the global image header being left in the tmp$ directory. + (8/6/97 LED) + +dataio$wfits.par +dataio$fits/t_wfits.x +dataio$doc/wfits.hlp + Added a new parameter call fextn whose default value is "fits" to the + wfits task. A ".fextn" suffix is appended to the output disk file names + to ensure that they are compatable with the fits kernel. + (6/20/97 LED) + +dataio$rfits.par +dataio$wfits.par +dataio$doc/rfits.hlp +dataio$doc/wfits.hlp +dataio$fits/fits_cards.x +dataio$fits/fits_files.x +dataio$fits/fits_params.x +dataio$fits/fits_read.x +dataio$fits/fits_rheader.x +dataio$fits/fits_rimage.x +dataio$fits/fits_rpixels.x +dataio$fits/fits_wheader.x +dataio$fits/fits_wimage.x +dataio$fits/fits_wpixels.x +dataio$fits/fits_write.x +dataio$fits/mkpkg +dataio$fits/rfits.com +dataio$fits/rfits.h +dataio$fits/t_rfits.x +dataio$fits/t_wfits.x +dataio$fits/wfits.com +dataio$fits/wfits.h + Installed new versions of rfits and wfits. The new rfits and wfits + include support for: 1) reading and writing multi-extension fits files, + 2) reading and writing global header, 3) reading and writing ushort + images by default when appropriate. + (6/9/97 LED) + + +dataio$doc/export.hlp +dataio$export/excmap.x +dataio$export/cmaps.inc + Added the 'overlay' cmap as a builtin cmap. (6/6/97) + +dataio$export/expreproc.x + Removed a call to scale the colormaps when using the default values. + Cmaps are now only scaled when a brightness/contrast value is set in + the setcmap() function. (6/6/97 MJF) + +dataio$export/bltins/exgif.x + Fixed a small error in the output of GIF files causing some display + programs to complain. GIF images which would now be an odd number of + bytes have an extra trailing ';' delimiter. This should be harmless + as all processing is supposed to stop once that char is found. (6/6/97 MJF) + +dataio$mkpkg +dataio$dataio.cl +dataio$dataio.hd +dataio$dataio.men +dataio$x_dataio.x +dataio$import/ + +dataio$import.par + +dataio$export/ + +dataio$export.par + +dataio$doc/import.hlp + +dataio$doc/export.hlp + + Installed the IMPORT/EXPORT task for general use. The images database + used by the IMPORT task is currently defined to be dataio$import/images.dat. + (3/31/97 MJF) + + +dataio$fits/fits_rheader.x + Explictly set SIMPLE(fits) to YES the first time this card is encountered + so that duplicate fits SIMPLE cards are properly filtered out. Duplicate + SIMPLE cards are illegal fits so this should never happen but ... + (6/28/96 Davis). + +dataio$fits/fits_cards.x + Added some wfits code to filter any "END " keywords out of the image + header userarea. + (3/17/95 Davis) + +dataio$fits/t_wfits.x + Wfits was using the name of the @file instead of the first file as the + root output fits file name if the number of output files was 1. + (1/18/95 Davis) + +dataio$fits/fits_wheader.x + The autoscaling code was failing in the case bitpix=16 and pixtype=ushort. + Bscale and bzero values were being set to 1.0 and 0.0 respectively, + resulting in truncation of data values. The code has been modified to + set bscale and bzero to 1.0 and 32768 instead.(10/18/94 Davis) + +dataio$imtext/t_rtextimage.x +dataio$imtext/t_wtextimage.x +dataio$imtext/rt_cvtpix.x +dataio$rtextimage.par +dataio$wtextimage.par +dataio$doc/rtextimage.hlp +dataio$doc/wtextimage.hlp + A parameter "pixels" was added to select whether to read or write + the pixel values. This is complementary to rfits/wfits and allows + use of these tasks to store and restore image headers. (10/22/93, Valdes) + +dataio$reblock/t_reblock.x: Davis, Jan 20, 1993 + Added support for multiple disk file input and output to the reblock + task. + +dataio$fits/fits_read: Davis, Apr 27, 1992 + Modified rfits to use the fe parameter to skip to EOF for devices + e.g. cartridge tapes which seem to be having problems with file + skips. + +dataio$fits/t_rfits.x: Davis, Mar 25, 1992 + Rfits was using the name of the @file instead of the first file as the + root output image name if the number of output files was 1. + +dataio$fits/fits_read: Davis, Feb 27, 1992 + Changed the interpreation of the fe parameter as read from dev$tapecap + from MB to KB. + +dataio$fits/fits_write: Davis, Feb 18, 1992 + Replaced a call to imgimage with one to imgcluster to extract the root + image name minus cluster and section. + +dataio$fits/t_rfits.x: Davis, Feb 18, 1992 +dataio$fits/t_wfits.x: Davis, Feb 18, 1992 + Changed the maximum sequence number that can be appended to an output + root image of fits file name from 999 to 9999. + +dataio$fits/rfits.com: Davis, Feb 18, 1992 +dataio$fits/t_rfits.x: Davis, Feb 18, 1992 +dataio$fits/fits_read.x: Davis, Feb 18, 1992 + Implemented a scan mode in rfits so that devices which have a slow + single-file file skip function (e.g. dat drives) can be used more + efficiently with the rfits make_image=no option. + +dataio$fits/fits_params.x: Davis, Feb 17, 1992 + Modified wfits so that string parameters that are 1) written explictly + by wfits, and 2) <= 20 characters long including quotes, will have the / + in column 33 instead of 2 spaces past the end of the string. The + affected keywords are OBJECT, ORIGIN, DATE, IRAFNAME, IRAF-BPX, and + IRAFTYPE. + +dataio$fits/fits_wheader.x: Davis, Feb 17, 1992 + Modified the short_header=yes option in wfits so that the image pixel + type, fits bitpix, and the scaling parameters are printed on the + standard output. + +dataio$fits/fits_rimage.x: Davis, Feb 17, 1992 +dataio$fits/fits_wimage.x: Davis, Feb 17, 1992 + Modified rfits so that the ieee +/-NaNs, and +/-Infs are correctly + mapped to a user specified native floating point number. Underflow values + are automatically converted to 0.0. A warning message is printed on + the terminal if any bad pixels were replaced. A warning message is + also printed if valid floating point pixel values > MAX_REAL or < + -MAX_REAL were detected. Imreplace can be used to replace these + explicitly. + +dataio$fits/fits_rheader.x: Davis, Feb 14, 1992 + Modified rfits to replace control characters decimal 0 (00X) to + 31 (1FX) and decimal 127 (7FX) with the blank character. The + new fits standard now explicitly defines these illegal in fits + headers. + +dataio$wfits.par: From, Davis, Feb 13, 1992 +dataio$doc/wfits.hlp: From, Davis, Feb 13, 1992 +dataio$fits/wfits.h: From, Davis, Feb 13, 1992 +dataio$fits/t_wfits.x: From, Davis, Feb 13, 1992 +dataio$fits/fits_write.x: From, Davis, Feb 13, 1992 +dataio$fits/fits_wheader.x: From, Davis, Feb 13, 1992 +dataio$fits/fits_wimage.x: From, Davis, Feb 13, 1992 +dataio$fits/fits_wpixels.x: From, Davis, Feb 13, 1992 + 1. Modified wfits to fetch the default fits blocking factor for a device + from the dev$tapecap file. The user can still overrride this value + (which is usually set to 10) for variable blocked devices, but is no + longer required to know or set the block size for fixed block devices + like cartridge tapes. + +dataio$mtexamine/t_mtexamine.x: From, Davis, Jan 6, 1992 +dataio$cardimage/t_rcardimage.x: From, Davis, Jan 6, 1992 +dataio$cardimage/t_wcardimage.x: From, Davis, Jan 6, 1992 +dataio$reblock/t_reblock.x: From, Davis, Jan 6, 1992 +dataio$fits/t_rfits.x: From, Davis, Jan 6, 1992 +dataio$fits/t_wfits.x: From, Davis, Jan 6, 1992 + 1. Modified the mtexamine, rcardimage, wcardimage, reblock, rfits, and + wfits tasks to accept the new magtape file name syntax. + +dataio$reblock/t_reblock.x: From, Davis, Dec 11, 1991 + 1. Modified reblock so that character constants like '\n' can be + used as record padding characters. + +dataio$t2d/mkpkg: From Davis, Dec 3, 1991 + 1. Removed the printf.h file dependency from the mkpkg. + +dataio$imtext/mkpkg: From Davis, Dec 3, 1991 + 1. Added missing files dependencies for the files rt_rheader.x + (imio.h) and wti_wheader.x (imio.h). + +dataio$fits/mkpkg: From Davis, Dec 3, 1991 +dataio$fits/fits_read.x + 1. Added missing files dependencies for the files fits_rheader.x + (ctype.h) and fits_wimage.x (error.h). + 2. Removed unused "include " statement from fits_read.x + +dataio$cardimage/mkpkg: From Davis, Dec 3, 1991 + 1. The entries for t_rcardimage.x and t_wcardimage.x were missing + several file dependencies. + +dataio$fits/fits_cards.x: From Davis, Oct 15, 1991 + 1. Changed the name of the IRAF-B/P keyword to IRAF-BPX to conform to the + new FITS standard. + +dataio$fits/fits_rpixels.x: From Davis, Oct 9, 1991 + 1. The rfits task has been modified to permit a short last record, i.e. + a last record that has not been padded out to 2880 bytes, without + generating any warning messages. + +dataio$fits/wfits.h: From Davis, Jun 11, 1991 +dataio$fits/t_wfits.x: From Davis, Jun 11, 1991 +dataio$fits/fits_write.x: From Davis, Jun 11, 1991 +dataio$fits/fits_wheader.x: From Davis, Jun 11, 1991 + 1. The wfits task has been modified to write IEEE format FITS files + (fits bitpix = -32 and -64), instead of scaled integers if the input + image pixel type is real or double respectively and if the wfits parameter + bitpix is left at the default. If the user overrides the default and + elects to scale the data, a warning message with an estimate of the + precision loss is provided. + +dataio$fits/fits_write.x: From Davis, Jun 10, 1991 +dataio$fits/fits_read.x: From Davis, Jun 10, 1991 + 1. Modified the fits writer and reader so that the IRAFNAME parameter + can deal with image sections. The fits writer will now record image + sections in the IRAFNAME parameter instead of inserting a blank. + The directory specification is still stripped. The fits reader will + now strip off any section notation before attempting to rename + the output image. + +dataio$fits/fits_rimage.x: From Davis, Jan 17, 1991 +dataio$fits/fits_wimage.x: From Davis, Jan 17, 1991 + 1. Modified the scaling routines in rfits and wfits to minimize + the precision lost when converting from real pixels to fits integers + and vice versa. + +dataio$cardimage/t_rcardimage.x: From Davis, Jan 3, 1991 +dataio$doc/rcardimage.hlp: From Davis, Jan 3, 1991 + 1. Modified rcardimage so that the error message encountered + when an odd-blocked rcardimage tape is encountered is less obscure. + 2. Modified the rcardimage help page to include an example of how to + reformat and odd-blocked cardimage tape with reblock. + +dataio$fits/t_rfits.x: From Davis, Dec 6, 1990 + 1. Modified rfits so that it will supply a temporary root output file + name if old_irafname="yes" and quit with a clear error message if + old_irafname="no", in the case where the user sets the output file + to the null string "". + +dataio$fits/fits_rheader.x: From Davis, Sept 11, 1990 + 1. Changed rfits so that history cards know go into the user area + instead of the history area where they get truncated. + +dataio$fits/wfits.h: From Davis, August 15, 1990 +dataio$fits/t_wfits.x: From Davis, August 15, 1990 +dataio$fits/fits_write.x: From Davis, August 15, 1990 +dataio$fits/fits_wimage.x: From Davis, August 15, 1990 +dataio$fits/fits_wpixels.x: From Davis, August 15, 1990 +dataio$fits/fits_rpixels.x: From Davis, August 15, 1990 + 1. Wfits will now permit FITS blocking factors up to and including + 22 although a warning message will be issued if a blocking factor + > 10 is requested. + + 2. Wfits occasionally crashed with a segmentation violation if a + non-standard fits blocking factor was selected. This error was + triggered if the unused portion of the output block to be blank + filled was greater than 2880 bytes. This bug has been fixed in + 2.10 + + 3. Rfits was not reading FITS data with a block size < 2880 on + the 9-track drives correctly. This bug has been fixed in 2.10. + + 4. Wfits.rfits now sets the length of the user area to the maximum of + the default of 28800 chars and the value of the environment variable + "min_lenuserarea". + +dataio$fits/fits_wheader.x: From Davis, July 3, 1990 +dataio$fits/fits_cards.x: From Davis, July 3, 1990 +dataio$fits/fits_rheader.x: From Davis, July 3, 1990 + Fixed a problem in the way bscale and bzero were computed that was + causing floating point errors for some double precision images, + basically because the precision was worse than I thought. + The really problem is that the min and max of a double precision + image are stored as reals in the image header do they do not + quite correspond to what is in the image. The solution was to extend + the values of the min and max to slightly lower and higher values + respectively. These problems will go away when ieee becomes more + accepted. (See messages below for history of this problem) + + Wfits now checks for the presence of the FITS keywords SIMPLE, BITPIX, + NAXIS and NAXISn in the user area and filters them out before writing + the FITS header. + + Rfits will now ignore FITS keywords that are duplicates of SIMPLE, + BITPIX, NAXIS and NAXISn. A warning message is issued if any of + these keywords are duplicated. + +dataio$fits/fits_wheader.x: From Davis, April 21 +dataio$fits/fits_write.x: From Davis, April 21 +dataio$fits/fits_read.x: From Davis, April 21 + The original scaling algorithm was restored due to problems encountered + with the new one. This will be looked into more fully in version 2.10. + These means that a problem with double precision images may remain. + + Since I had to make the above change at the last minute I added some + code to flush the STDOUT after in input and output file names + are computed and written to STDOUT. This avoids a problem with + output not being flushed when an error condition occurs and output + is being redirected causing confusion for the user who may not be able + to tell where the error occured in that case. + +dataio$fits/fits_wheader.x: From Davis, Mar 24, 1990 + Fixed a problem with the scaling routines in wfits. Images with a + minimum which was negative and distant from the majority of the + data values could cause a problem in the scaling. + +dataio$fits/fits_rimage.x: From Davis, Mar 10, 1990 + Recoded the routine that computes the mins and maxs of an image + slightly to remove a problem with the STF kernel. The mins and maxs + of the image were being reset to 0 when the first data was written + over-riding the program initialization of MAX_REAL and -MAX_REAL + and defeating the minimum calculation for all positive data. + +dataio$fits/fits_wheader.x: From Davis, Mar 9, 1990 + Fixed a problem in the way bscale and bzero were computed that was + causing floating point errors for some double precision images, + basically because the precision was worse than I thought. + The really problem is that the min and max of a double precision + image are stored as reals in the image header do they do not + quite correspond to what is in the image. The solution was to extend + the values of the min and max to slightly lower and higher values + respectively. These problems will go away when ieee becomes more + accepted. + +dataio$fits/fits_cards: From Davis, Jan 20, 1990 + Added a filter to remove duplicate IRAF-MIN, IRAF-MAX, IRAFTYPE, + and IRAF-B/P keywords from the user area. + +dataio$fits: From Davis, Jan 19, 1990 + 1. Support was added for the IEEE floating point format to both + the rfits and wfits tasks. Rfits now recognizes -32 and -64 to + be legal values of bitpix representing respectively real and + double IEEE floating point format. Values of bscale and bzero + are applied if present in the header. By default wfits still + writes integer format FITS tapes with autoscaling. However if + the users selects a bitpix of -32 or -64 the appropriate floating + point format is written. In this case scaling is disabled. + + 2. Rfits was modified to take a list of output images names or + an output image root name. + + 3. Wfits was modified to take a list of output fits file names + or an output fits file root name. + +dataio$fits/fits_wheader.x: From Davis, Nov 20, 1989 + 1. Fixed wfits so it would write out type "ushort" images correctly + with the default parameters. The chosen bitpix is 32 instead of + 16. + +dataio$fits/t_rfits.x,t_wfits.x: From Davis, May 29, 1989 + 1. Changed both these tasks so the STDOUT is only flushed on a newline + if has not been redirected. Changed the remaining eprintf statements + to printf statements. + +dataio$fits/fits_rheader.x: From Davis, May 9, 1989 + 1. Fixed abug in the code which decodes hms format numbers. The + problem was caused by leading blanks and the fact that the ctoi + routine does not recognize the plus character. + +dataio$fits/t_wfits.x: From Davis, Mar 31, 1989 +dataio$fits/wft_wimage.x: From Davis, Mar 31, 1989 +dataio$fits/wft_wpixels.x: From Davis, Mar 31, 1989 + 1. Changed wfits so that a warning message is printed if the fits + long blocks option is used. The previous version only warned the + user if an illegal fits block size was used. + 2. Changed wfits so that the record structure written is printed + out on the standard output if short_header = yes as well as if + long_header = yes. + 3. Changed the error trapping code so that the number of records + actually written is printed out when wfits terminates prematurely + with an error condition. + + +dataio$fits/t_wfits.x: From Davis, Mar 14, 1989 +dataio$fits/fits_rpixels: From Davis, Mar 14, 1989 + 1. Changed wfits so that warning messages are printed if the user + overrides the default value of bitpix or turns of autoscaling. + These messages will be printed to the standard output along with + the output log. + 2. I have fixed a problem in the error checking code in rfits. + Too many reads were being done after an error recovery resulting + in the data in the output image being skewed. This needs to be + rechecked on DRACO where the original error recovery was done. + +dataio$reblock: From Davis, Jan 27, 1989 + 1. Fixed a problem in reblock for tape to tape copies. The copyn parameter + was being ignored if no reblocking was occurring. This problem has been + fixed. A minor problem with the record counter was also fixed. + +dataio$fits: From Davis, Apr 14, 1988 + 1. Added an option in wfits to write a non-standard physical block size + of blocking_factor > 10. This permits users with restricted block + size devices to read and write fits tapes. + + 2. Changed the cl file name template commands inside wfits to images + name template commands. + +dataio$fits: From Davis, Mar23, 1988 + 1. Fixed a bug in the fits string parameter trimming routine in which + the newline was being overwritten if the string was exactly 80 + characters long. + +dataio$rfits: From Davis, December 11, 1987 + 1. Fixed a small bug in the rfits disk handling code. If a user + successfully read a fits disk file, for example fitsdat, and then + tried to read a list of files using a template which did not match + any of the disk files, rfits would try to reread fitsdat. Rfits was + not handling the 0 length disk file list condition correctly. + +dataio$rfits: From Davis, December 3, 1987 + 1. Rfits now checks for valid bscale and bzero values. If it cannot + decode bscale or bzero it sets them to 1.0 and 0.0 respectively. + 2. Rfits and wfits no longer flushes STDOUT on a newline if the output + has been redirected to a file. This greatly improves the speed of rfits + and wfits when the long_header parameter is set to yes especially for + VMS systems. + +dataio$rfits: From Davis, September 3, 1987 + Rfits will now print out the ol irafname if short_header = yes, make_image + = no and old_name = yes. This makes it easier for users to list their + IRAF fits tapes. + +dataio$reblock/t_reblock.x: From Davis, August 12, 1987 + The offset parameter in reblock was not being queried for by + the code. + +dataio$imtext/rt_rheader.x,wti_wheader.x: From SJacoby, June 10, 1987: + Tasks RTEXTIMAGE and WTEXTIMAGE no longer limit the image user area + being written to or read from to 2880 chars. The size of the + user area to be created or accessed by these tasks is controlled + by the IRAF environment variable `min_lenuserarea', and is not + limited by the code. + +dataio$fits/fits_rheader.x: From Davis, June 4, 1987: + The code for reading fits cards into the user area has been changed. + Rfits opens a new image with the default min_lenuserarea and + reads cards into it until it is filled. If the user area is + completely filled rfits issues a warning message along with the + number of fits parameters it was not able to completely store. + +dataio$fits/fits_write.x,fits_read.x,fits_rpixels.x: From Davis, May 15, 1987: + 1. I changed the error checking code so that it would work correctly + with the fits long blocks option. Wfits now does a call to fstat + to find out the number of bytes in the last read and uses this number + to validate the buffer if a read error occurs. There is no way to + recover from a read error in the tape record containing the header info. + 2. I added a check for the maximum permitted buffer size in wfits. + The program will abort if the device cannot suuport the length of + the output record requested. + +dataio$mtexamine/t_mtexamine.x: From Davis, May 15, 1987: + Error checking code has been added to MTEXAMINE. The task will now + print out a warning message for each bad record encountered and + continue reading the file instead of skipping to the next file. + The correct record count is preserved. + +dataio$imtext/wti_wheader.x, dataio$imtext/rt_rheader.x: Hammond, Mar 24, l987. + The FITS format header written by task WTEXTIMAGE has been changed. It + no longer contains the keywords SIMPLE=T and NAXIS=0. The output of + WTEXTIMAGE is a simple text file which makes no attempt to conform to + FITS standards. Task RTEXTIMAGE was modified to read both the old and + new format headers. + +dataio$t2d/t_t2d.x: From Lytle, Mar 20, 1987: + 1. T2D now deletes the zero length file left over when the program + encounters the end-of-tape and opens and closes an empty file. + 2. I also changed the verbose output format somewhat to make it + more logical. + +dataio$t_wcardimage: From Davis, Mar 19, 1987: + 1. WCARDIMAGE now checks that the input files are not binary + files before trying to write them to tape. + +dataio$fits: From Davis, Mar 19, 1987: + 1. More extensive error checking has been added to the FITS code. + Rfits attempts to recover from a read error in the data matrix. + Instead of terminating with a partially written image RFITS will + try to skip over the bad data. The resulting output image will + have the correct number of rows and columns but may contain one + or more records of bad data. The results of the error checking + may be tape drive dependent. + 2. RFITS now prints a warning message if no pixel file is + written (NAXIS = 0). + 3. RFITS now checks the first 6 characters of the first header record + to see if they are equal to SIMPLE. + +dataio$fits_wheader.x: From Davis, Jan 28, 1987: + 1. The scaling routine for determining bscale and bzero + introduced by Skip for the MV10000 was found to have problems + with some low dynamic range data. The symptom was that + the min value of an image restored from a FITS data would + have larger than expected roundoff errors. I have changed it back + to my original scaling algorithm. + +dataio$cardimage/: From Davis, Jan 20, 1987: + 1. Rcardimage has been modified to accept a list of disk files as + input as well as a list of tape files. + +dataio$fits/: From Davis, Jan 20, 1987 + 1. The FITS longblocks option has been added to the FITS readers and + writers. RFITS will read long-blocked FITS data. The redundant + len_record parameter has been removed. IRAF mtio handles the tape + record buffering transparently. + 2. The len_record parameter has been removed from WFITS and + replaced with a blocking parameter factor, which specifies the number + of 2880 byte FITS records can be written in a single tape block. + The maximum legal FITS blocking factor is 10. + 3. RFITS has been modified to accept a list of disk files as well as + a list of tape files. This should facilitate file transfers over + the ethernet. + +dataio$reblock/reb_reblock_file.x: From Davis, Dec 12, 1986 + 1. A bug in the seek option on disk binary files has been fixed. + This bug would cause the number of bytes read to be incorrectly + computed. + +dataio$lib/addcards.x: From Hammond, Oct 27, 1986 + Header cards containing real values are now written with a %g rather + than %f format. This change affects task wtextimage. + +dataio$fits/fits_wheader.x: From Davis, Oct2 + 1. The way the scaling routine wft_set_scale computes the data range + has been changed. Instead of adjusting maxdata and mindata individually + for machine precision; the data range is first computed and then adjusted + for the machine precision. This change was made in response to precision + problems encountered on the MV10000. + +dataio$fits/wfits.h: From Davis, Sep12, 1986 + 1. The integer constants BYTE_MIN, BYTE_MAX, BYTE_BLANK etc have been + changed to type double to avoid compiler generated integer overflows. + The data type of TAPEMIN and TAPEMAX in the WFITS structure has also + been changed to double. This change was made in response to compiler + errors encountered on the MV10000 and should be transparent to the users. + +dataio$imtext/rt_cvtpix.x: From Hammond, Sep2, 1986 + A typographical error was corrected in a call to patmake. The + pattern "[DdEd]" has been replaced with the correct pattern "[DdEe]". + This means numbers written with a lower case 'e' in the exponent field + are recognized as floating point numbers when read from the text file. + This procedure is called by task RTEXTIMAGE. + +dataio$mtexamine/t_mtexamine.x: From Davis, Aug20, 1986 + 1. MTEXAMINE on the SUN was outputting an array of zeroes when asked to + dump records with output_type = c. The problem was that a long integer + was being passed to the routine ctocc instead of a char. This error + was not being detected on the VAXES. + +dataio$fits/fits_params.x: From Davis, Aug20, 1986 + 1. The boolean parameter param in routine wft_encodeb was changed to type + integer. Wft_encodeb was being called with param = YES which caused + portability problems on the MV10000. + +From Davis July 16, 1986: + +1. RFITS has been modified so that imbedded blanks in the UT, ZD, ST, RA and +DEC keywords are replaced by zeros. For example the mountain fits writers +produce hms numbers of the form 20: 6: 3. RFITS will convert this to 20:06:03. + +----------------------------------------------------------------------------- + +From Davis June 13, 1986: + +1. TXTBIN and BINTXT have been modified so that the file number is +appended to the output file name. Previous versions appended the extensions +".txt" and ".bin" to the input file name. + +------------------------------------------------------------------------------ + +From Davis June 12, 1986: + +1. WCARDIMAGE and WFITS now append a file number to the output file name +if multiple disk files are being written. In the old writers a suffix +was appended to the input file name (.fit for WFITS and .crd for +WCARDIMAGE) and the output images were being copied to the input +directory. + +------------------------------------------------------------------------------ + +From Davis June 8, 1986: + +1. WFITS has been modified to store only the root of the image name. All +pathname information has been stripped off. + +------------------------------------------------------------------------------ + +From Davis May 28, 1986: + +1. The output of WFITS has been changed to print the file number, input file +name, output file name, title and dimensions if long_header = no and +short_header = yes. + +------------------------------------------------------------------------------- + +From Davis May 22, 1986: + +1. RFITS now writes 80 character records into the user area instead of +trimming trailing whitespace from each record. This was changed to facilitate +the image database interface. This change was also made to WTEXTIMAGE. + +------------------------------------------------------------------------------- + +From Davis May 21, 1986: + +A bug in the record trimming code of REBLOCK has been fixed. REBLOCK was +computing the offset in the input block of data incorrectly. + +-------------------------------------------------------------------------------- + +From Davis May 13, 1986: + +A bug in the error checking code in MTEXAMINE has been fixed. If there is an +error on mtopen the program will abort instead of trying to open the next file. + +-------------------------------------------------------------------------------- + +From Davis May 1, 1986: + +A problem with the autoscaling option in WFITS has been fixed. In order +to avoid wrap around problems WFITS now assumes that the number of digits +of machine precision is 1 less than the number in mach.h. In the case of +the Vax the number is actually 6.? not 7 as quoted. + +----------------------------------------------------------------------------- + +From Davis Apr 17, 1986: + +Changed boolean == false constructs in files t_wcardimage.x and t_reblock.x +to ! boolean. + +---------------------------------------------------------------------------- + +From Davis Apr 4, 1986: + +The format of the RCAMERA DATE-OBS parameter has been changed form +dd-mm-yyyy to dd/mm/yyyy to bring it into conformity with FITS standard. + +--------------------------------------------------------------------------- + +From Hammond Mar 25, 1986: + +Task RTEXTIMAGE has been fixed so it properly skips over non standard fits +headers, the number of lines being specified by the parameter nskip. + +___________________________________________________________________________ + +From Davis Mar 9, 1986: + +The order of the REBLOCK parameters outfiles and file_list has been switched +in order to preserve the correct command line sequence + +---------------------------------------------------------------------------- + +From Davis Mar 3, 1986: + +The error checking in WFITS has been corrected so that WFITS terminates if +it encounters a file write error instead of continuing to the next file +as done previously. + +---------------------------------------------------------------------------- + +From Davis Feb 19, 1986: + +1. Rfits and rpds have been fixed so that attempting to delete the last +empty image does not generate a cannot delete protected file message. + +---------------------------------------------------------------------------- + +From Davis Feb 3, 1986: + +1. A mysterious bug in which the date of observation card would sometimes +not appear in the header has been fixed. A newline was missing from the +proceeding header card. + +---------------------------------------------------------------------------- + +From Davis Jan 16, 1986: + +1. Wfits no longer needs write permission to work. However as a consequence +wfits no longer updates the image min and max. + +2. The scaling routines in rfits and wfits fits have been replaced by +appropriate vector operators. + +3. The coordinate transformation parameters are now stored in the user +area and are available to hedit, imgets etc. + +4. Scaled data is now read into real images regardless of the value of +bitpix. + +----------------------------------------------------------------------------- + +From Davis Jan. 5, 1986: + +1. Rfits, rpds and rcamera now open dev$null instead of a temporary disk +file for option make_image = no. This eliminates a lot od disk access overhead +and should speed up these readers considerably. + +2. The default parameter options are now long_header=no and short_header=yes. +Setting the long_header parameter to yes will over-ride the short header +parameter. + +--------------------------------------------------------------------------- + +From Davis Dec. 3, 1985: + +1. Rcamera will now print and store the header parameters ccdpicno and airmass +if defined. + +2. A bug in the fringe scaling parameter calculation in rcamera was fixed. +Currently the mountain programs store this number in floating point format. +This will be changed in future necessitating a corresponding change in +rcamera. + +----------------------------------------------------------------------- +From Valdes Oct. 10, 1985: + +1. Defined widstape from ONEDSPEC package in the DATAIO package. The +source and executable, however, still reside in ONEDSPEC (x_onedutil.e). +Widstape and widsout should be combined and the source put in DATAIO +at some point. +.endhelp diff --git a/pkg/dataio/bintext/mkpkg b/pkg/dataio/bintext/mkpkg new file mode 100644 index 00000000..ff3db34f --- /dev/null +++ b/pkg/dataio/bintext/mkpkg @@ -0,0 +1,11 @@ +# Bintext library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_bintxt.x + t_txtbin.x + ; diff --git a/pkg/dataio/bintext/t_bintxt.x b/pkg/dataio/bintext/t_bintxt.x new file mode 100644 index 00000000..13b1e328 --- /dev/null +++ b/pkg/dataio/bintext/t_bintxt.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define MAX_RANGES 100 + +# T_BINTXT -- Procedure to convert binary files containing only text to text +# files. + +procedure t_bintxt() + +bool verbose +char outfile[SZ_FNAME] + +char infile[SZ_FNAME], out_fname[SZ_FNAME] +int list, len_list, in, out, file_number + +bool clgetb() +int strlen(), open(), clpopni(), clplen(), clgfil() + +begin + # Get input files + list = clpopni ("binary_file") + len_list = clplen (list) + + # Get output files + call clgstr ("text_file", outfile, SZ_FNAME) + + verbose = clgetb ("verbose") + + file_number = 1 + while (clgfil (list, infile, SZ_FNAME) != EOF) { + + if (len_list > 1) { + call strcpy (outfile, out_fname, SZ_FNAME) + call sprintf (out_fname[strlen(out_fname) + 1], SZ_FNAME, + "%03d") + call pargi (file_number) + } else + call strcpy (outfile, out_fname, SZ_FNAME) + + iferr { + + if (verbose) { + call printf ("File: %s -> %s\n") + call pargstr (infile) + call pargstr (out_fname) + } + + # Open input and output files, copy and close files + in = open (infile, READ_ONLY, BINARY_FILE) + out = open (out_fname, NEW_FILE, TEXT_FILE) + call fcopyo (in, out) + call close (in) + call close (out) + + } then { + if (verbose) { + call eprintf ("Cannot read file %s\n") + call pargstr (infile) + } + } else + file_number = file_number + 1 + } + + call clpcls (list) +end diff --git a/pkg/dataio/bintext/t_txtbin.x b/pkg/dataio/bintext/t_txtbin.x new file mode 100644 index 00000000..038a71ec --- /dev/null +++ b/pkg/dataio/bintext/t_txtbin.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# T_TXTBIN -- Procedure to convert text files to binary files. + +procedure t_txtbin () + +bool verbose +char outfile[SZ_FNAME] + +char infile[SZ_FNAME], out_fname[SZ_FNAME] +int list, len_list, in, out, file_number + +bool clgetb() +int clpopni(), clplen(), clgfil(), strlen(), open() + +begin + # Get list of input files + list = clpopni ("text_file") + len_list = clplen (list) + + # Get output file name + call clgstr ("binary_file", outfile, SZ_FNAME) + + verbose = clgetb ("verbose") + + # Loop over the files + file_number = 1 + while (clgfil (list, infile, SZ_FNAME) != EOF) { + + if (len_list > 1 ) { + call strcpy (outfile, out_fname, SZ_FNAME) + call sprintf (out_fname[strlen(out_fname) + 1], SZ_FNAME, + "%03d") + call pargi (file_number) + } else + call strcpy (outfile, out_fname, SZ_FNAME) + + iferr { + + if (verbose) { + call printf ("File: %s -> %s\n") + call pargstr (infile) + call pargstr (out_fname) + call flush (STDERR) + } + + # Open input and output files, copy and close input and + # output files. + in = open (infile, READ_ONLY, TEXT_FILE) + out = open (out_fname, NEW_FILE, BINARY_FILE) + call fcopyo (in, out) + call close (in) + call close (out) + + } then { + call eprintf ("Cannot read file: %s\n") + call pargstr (infile) + } else + file_number = file_number + 1 + } + call clpcls (list) +end + + + diff --git a/pkg/dataio/bintxt.par b/pkg/dataio/bintxt.par new file mode 100644 index 00000000..359f9931 --- /dev/null +++ b/pkg/dataio/bintxt.par @@ -0,0 +1,4 @@ +mode,s,h,"ql",,, +binary_file,s,a,,,,Input file name(s) +text_file,s,a,,,,Output file name +verbose,b,h,yes,,,Print messages? diff --git a/pkg/dataio/cardimage/conversion.x b/pkg/dataio/cardimage/conversion.x new file mode 100644 index 00000000..0d6f78af --- /dev/null +++ b/pkg/dataio/cardimage/conversion.x @@ -0,0 +1,221 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define MAX_CHARS 256 + + +# ASCII_TO_EBCDIC -- Vector procedure to convert ASCII characters to EBCDIC +# characters using the lookup table atoe. + +procedure ascii_to_ebcdic (inbuffer, outbuffer, nchars) + +char inbuffer[ARB] +short outbuffer[ARB], atoe[MAX_CHARS] +int l, nchars + +data (atoe[l], l = 1, 8) / 0b, 1b, 2b, 3b, '7' , '-' , '.' , '/' / +data (atoe[l], l = 9, 16) /26b, 5b, '%' , 13b, 14b, 15b, 16b, 17b / +data (atoe[l], l = 17, 24) /20b, 21b, 22b, 23b, '<' , '=' , '2' , '&' / +data (atoe[l], l = 25, 32) /30b, 31b, '?' , '\'', 34b, 35b, 36b, 37b / +data (atoe[l], l = 33, 40) /'@' , 'O' , 177b, '{' , '[' , 'l' , 'P' , '}' / +data (atoe[l], l = 41, 48) /'M' , ']' , '\\' , 'N' , 'k' , '`' , 'K' , 'a'/ +data (atoe[l], l = 49, 56) /360b, 361b, 362b, 363b, 364b, 365b, 366b, 367b/ +data (atoe[l], l = 57, 64) /370b, 371b, 'z' , '^' , 'L' , '~' , 'n' , 'o' / +data (atoe[l], l = 65, 72) /'|' , 301b, 302b, 303b, 304b, 305b, 306b, 307b/ +data (atoe[l], l = 73, 80) /310b, 311b, 321b, 322b, 323b, 324b, 325b, 326b/ +data (atoe[l], l = 81, 88) /327b, 330b, 331b, 342b, 343b, 344b, 345b, 346b/ +data (atoe[l], l = 89, 96) /347b, 350b, 351b, 'J' , 340b, 'Z' , '_' , 'm' / +data (atoe[l], l = 97, 104) /'y' , 201b, 202b, 203b, 204b, 205b, 206b, 207b/ +data (atoe[l], l = 105, 112) /210b, 211b, 221b, 222b, 223b, 224b, 225b, 226b/ +data (atoe[l], l = 113, 120) /227b, 230b, 231b, 242b, 243b, 244b, 245b, 246b/ +data (atoe[l], l = 121, 128) /247b, 250b, 251b, 300b, 'j' , 320b, 241b, 7b/ +data (atoe[l], l = 129, 136) /' ' , '!' , '"' , '#' , '$' , 25b, 6b, 27b/ +data (atoe[l], l = 137, 144) /'(' , ')' , '*' , '+' , ',' , 11b, 12b, 33b/ +data (atoe[l], l = 145, 152) /'0' , '1' , 32b, '3' , '4' , '5' , '6' , 10b/ +data (atoe[l], l = 153, 160) /'8' , '9' , ':' , ';' , 4b, 24b, '>' , 341b/ +data (atoe[l], l = 161, 168) /'A' , 'B' , 'C' , 'D' , 'E' , 'F' , 'G' , 'H' / +data (atoe[l], l = 169, 176) /'I' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' / +data (atoe[l], l = 177, 184) /'X' , 'Y' , 'b' , 'c' , 'd' , 'e' , 'f' , 'g' / +data (atoe[l], l = 185, 192) /'h' , 'i' , 'p' , 'q' , 'r' , 's' , 't' , 'u' / +data (atoe[l], l = 193, 200) /'v' , 'w' , 'x' , 200b, 212b, 213b, 214b, 215b/ +data (atoe[l], l = 201, 208) /216b, 217b, 220b, 232b, 233b, 234b, 235b, 236b/ +data (atoe[l], l = 209, 216) /237b, 240b, 252b, 253b, 254b, 255b, 256b, 257b/ +data (atoe[l], l = 217, 224) /260b, 261b, 262b, 263b, 264b, 265b, 266b, 267b/ +data (atoe[l], l = 225, 232) /270b, 271b, 272b, 273b, 274b, 275b, 276b, 277b/ +data (atoe[l], l = 233, 240) /312b, 313b, 314b, 315b, 316b, 317b, 332b, 333b/ +data (atoe[l], l = 241, 248) /334b, 335b, 336b, 337b, 352b, 353b, 354b, 355b/ +data (atoe[l], l = 249, 256) /356b, 357b, 372b, 373b, 374b, 375b, 376b, 377b/ + +begin + call alutcs (inbuffer, outbuffer, nchars, atoe) +end + + +# EBCDIC_TO_ASCII -- Vector procedure to convert EBCDIC characters to ASCII +# characters. + +procedure ebcdic_to_ascii (inbuffer, outbuffer, nchars) + +char outbuffer[ARB] +short inbuffer[ARB], etoa[MAX_CHARS] +int l, nchars + +data (etoa[l], l = 1, 8) / 0b, 1b, 2b, 3b, 234b, 11b, 206b, 177b / +data (etoa[l], l = 9, 16) /227b, 215b, 216b, 13b, 14b, 15b, 16b, 17b/ +data (etoa[l], l = 17, 24) /20b, 21b, 22b, 23b, 235b, 205b, 10b, 207b / +data (etoa[l], l = 25, 32) /30b, 31b, 222b, 217b, 34b, 35b, 36b, 37b / +data (etoa[l], l = 33, 40) /200b, 201b, 202b, 203b, 204b, 12b, 27b, 33b/ +data (etoa[l], l = 41, 48) /210b, 211b, 212b, 213b, 214b, 5b, 6b, 7b/ +data (etoa[l], l = 49, 56) /220b, 221b, 26b, 223b, 224b, 225b, 226b, 4b/ +data (etoa[l], l = 57, 64) /230b, 231b, 232b, 233b, 24b, 25b, 236b, 32b/ +data (etoa[l], l = 65, 72) /' ' , 240b, 241b, 242b, 243b, 244b, 245b, 246b/ +data (etoa[l], l = 73, 80) /247b, 250b, '[' , '.' , '<' , '(' , '+' , '!' / +data (etoa[l], l = 81, 88) /'&' , 251b, 252b, 253b, 254b, 255b, 256b, 257b/ +data (etoa[l], l = 89, 96) /260b, 261b, ']' , '$' , '*' , ')' , ';' , '^' / +data (etoa[l], l = 97, 104) /'-' , '/' , 262b, 263b, 264b, 265b, 266b, 267b/ +data (etoa[l], l = 105, 112) /270b, 271b, '|' , ',' , '%' , '_' , '>' , '?' / +data (etoa[l], l = 113, 120) /272b, 273b, 274b, 275b, 276b, 277b, 300b, 301b/ +data (etoa[l], l = 121, 128) /302b, '`' , ':' , '#' , '@' , '\'' , '=' , '"'/ +data (etoa[l], l = 129, 136) /303b, 'a' , 'b' , 'c' , 'd' , 'e' , 'f' , 'g' / +data (etoa[l], l = 137, 144) /'h' , 'i' , 304b, 305b, 306b, 307b, 310b, 311b/ +data (etoa[l], l = 145, 152) /312b, 'j' , 'k' , 'l' , 'm' , 'n' , 'o' , 'p' / +data (etoa[l], l = 153, 160) /'q' , 'r' , 313b, 314b, 315b, 316b, 317b, 320b/ +data (etoa[l], l = 161, 168) /321b, '~' , 's' , 't' , 'u' , 'v' , 'w' , 'x' / +data (etoa[l], l = 169, 176) /'y' , 'z' , 322b, 323b, 324b, 325b, 326b, 327b/ +data (etoa[l], l = 177, 184) /330b, 331b, 332b, 333b, 334b, 335b, 336b, 337b/ +data (etoa[l], l = 185, 192) /340b, 341b, 342b, 343b, 344b, 345b, 346b, 347b/ +data (etoa[l], l = 193, 200) /'{' , 'A' , 'B' , 'C' , 'D' , 'E' , 'F' , 'G' / +data (etoa[l], l = 201, 208) /'H' , 'I' , 350b, 351b, 352b, 353b, 354b, 355b/ +data (etoa[l], l = 209, 216) /'}' , 'J' , 'K' , 'L' , 'M' , 'N' , 'O' , 'P' / +data (etoa[l], l = 217, 224) /'Q' , 'R' , 356b, 357b, 360b, 361b, 362b, 363b/ +data (etoa[l], l = 225, 232) /'\\', 237b, 'S' , 'T' , 'U' , 'V' , 'W' , 'X' / +data (etoa[l], l = 233, 240) /'Y' , 'Z' , 364b, 365b, 366b, 367b, 370b, 371b/ +data (etoa[l], l = 241, 248) /'0' , '1' , '2' , '3' , '4' , '5' , '6' , '7' / +data (etoa[l], l = 249, 256) /'8' , '9' , 372b, 373b, 374b, 375b, 376b, 377b/ + +begin + call alutsc (inbuffer, outbuffer, nchars, etoa) +end + + +# IBM_TO_ASCII -- Vector procedure for converting IBM characters to ASCII +# characters. + +procedure ibm_to_ascii (inbuffer, outbuffer, nchars) + +char outbuffer[ARB] +short inbuffer[ARB], ibmtoa[MAX_CHARS] +int l, nchars + +data (ibmtoa[l], l = 1, 8) /0b, 1b, 2b, 3b, 234b, 11b, 206b, 177b / +data (ibmtoa[l], l = 9, 16) /1227b, 215b, 216b, 13b, 14b, 15b, 16b, 17b/ +data (ibmtoa[l], l = 17, 24) /20b, 21b, 22b, 23b, 235b, 205b, 10b, 207b / +data (ibmtoa[l], l = 25, 32) /30b, 31b, 222b, 217b, 34b, 35b, 36b, 37b / +data (ibmtoa[l], l = 33, 40) /200b, 201b, 202b, 203b, 204b, 12b, 27b, 33b/ +data (ibmtoa[l], l = 41, 48) /210b, 211b, 212b, 213b, 214b, 5b, 6b, 7b/ +data (ibmtoa[l], l = 49, 56) /220b, 221b, 26b, 223b, 224b, 225b, 226b, 4b/ +data (ibmtoa[l], l = 57, 64) /230b, 231b, 232b, 233b, 24b, 25b, 236b, 32b/ +data (ibmtoa[l], l = 65, 72) /' ' , 240b, 241b, 242b, 243b, 244b, 245b, 246b/ +data (ibmtoa[l], l = 73, 80) /247b, 250b, 0b, '.' , '<' , '(' , '+' , '|' / +data (ibmtoa[l], l = 81, 88) /'&' , 251b, 252b, 253b, 254b, 255b, 256b, 257b/ +data (ibmtoa[l], l = 89, 96) /260b, 261b, '!' , '$' , '*' , ')' , ';' , '^' / +data (ibmtoa[l], l = 97, 104) /'-' , '/' , 262b, 263b, 264b, 265b, 266b, 267b/ +data (ibmtoa[l], l = 105,112) /270b, 271b, 0b, ',' , '%' , '_' , '>' , '?' / +data (ibmtoa[l], l = 113, 120) /272b, 273b, 274b, 275b, 276b, 277b, 300b, 301b/ +data (ibmtoa[l], l = 121, 128) /302b, '`' , ':' , '#' , '@' , '\'' , '=' , '"'/ +data (ibmtoa[l], l = 129, 136) /303b, 'a' , 'b' , 'c' , 'd' , 'e' , 'f' , 'g' / +data (ibmtoa[l], l = 137, 144) /'h' , 'i' , 304b, 305b, 306b, 307b, 310b, 311b/ +data (ibmtoa[l], l = 145, 152) /312b, 'j' , 'k' , 'l' , 'm' , 'n' , 'o' , 'p' / +data (ibmtoa[l], l = 153, 160) /'q' , 'r' , 313b, 314b, 315b, 316b, 317b, 320b/ +data (ibmtoa[l], l = 161, 168) /321b, '~' , 's' , 't' , 'u' , 'v' , 'w' , 'x' / +data (ibmtoa[l], l = 169, 176) /'y' , 'z' , 322b, 323b, 324b, 325b, 326b, 327b/ +data (ibmtoa[l], l = 177, 184) /330b, 331b, 332b, 333b, 334b, 335b, 336b, 337b/ +data (ibmtoa[l], l = 185, 192) /340b, 341b, 342b, 343b, 344b, 345b, 346b, 347b/ +data (ibmtoa[l], l = 193, 200) /'{' , 'A' , 'B' , 'C' , 'D' , 'E' , 'F' , 'G' / +data (ibmtoa[l], l = 201, 208) /'H' , 'I' , 350b, 351b, 352b, 353b, 354b, 355b/ +data (ibmtoa[l], l = 209, 216) /'}' , 'J' , 'K' , 'L' , 'M' , 'N' , 'O' , 'P' / +data (ibmtoa[l], l = 217, 224) /'Q' , 'R' , 356b, 357b, 360b, 361b, 362b, 363b/ +data (ibmtoa[l], l = 225, 232) /'\\', 237b, 'S' , 'T' , 'U' , 'V' , 'W' , 'X' / +data (ibmtoa[l], l = 233, 240) /'Y' , 'Z' , 364b, 365b, 366b, 367b, 370b, 371b/ +data (ibmtoa[l], l = 241, 248) /'0' , '1' , '2' , '3' , '4' , '5' , '6' , '7' / +data (ibmtoa[l], l = 249, 256) /'8' , '9' , 372b, 373b, 374b, 375b, 376b, 377b / + +begin + call alutsc (inbuffer, outbuffer, nchars, ibmtoa) +end + + +# ASCII_TO_IBM -- Vector procedure to convert ASCII characters to IBM +# characters. + +procedure ascii_to_ibm (inbuffer, outbuffer, nchars) + +char inbuffer[ARB] +short outbuffer[ARB], atoibm[MAX_CHARS] +int l, nchars + +data (atoibm[l], l = 1, 8) /0b, 1b, 2b, 3b, '7' , '-' , '.' , '/' / +data (atoibm[l], l = 9, 16) /26b, 5b, '%' , 13b, 14b, 15b, 16b, 17b / +data (atoibm[l], l = 17, 24) /20b, 21b, 22b, 23b, '<' , '=' , '2' , '&' / +data (atoibm[l], l = 25, 32) /30b, 31b, '?' , '\'', 34b, 35b, 36b, 37b / +data (atoibm[l], l = 33, 40) /'@' , 'Z' , 177b, '{' , '[' , 'l' , 'P' , '}' / +data (atoibm[l], l = 41, 48) /'M' , ']' , '\\', 'N' , 'k' , '`' , 'K' , 'a' / +data (atoibm[l], l = 49, 56) /360b, 361b, 362b, 363b, 364b, 365b, 366b, 367b/ +data (atoibm[l], l = 57, 64) /370b, 371b, 'z' , '^' , 'L' , '~' , 'n' , 'o' / +data (atoibm[l], l = 65, 72) /'|' , 301b, 302b, 303b, 304b, 305b, 306b, 307b/ +data (atoibm[l], l = 73, 80) /310b, 311b, 321b, 322b, 323b, 324b, 325b, 326b/ +data (atoibm[l], l = 81, 88) /327b, 330b, 331b, 342b, 343b, 344b, 345b, 346b/ +data (atoibm[l], l = 89, 96) /347b, 350b, 351b, 255b, 340b, 275b, '_' , 'm' / +data (atoibm[l], l = 97, 104) /'y' , 201b, 202b, 203b, 204b, 205b, 206b, 207b/ +data (atoibm[l], l = 105, 112) /210b, 211b, 221b, 222b, 223b, 224b, 225b, 226b/ +data (atoibm[l], l = 113, 120) /227b, 230b, 231b, 242b, 243b, 244b, 245b, 246b/ +data (atoibm[l], l = 121, 128) /247b, 250b, 251b, 300b, 'O' , 320b, 241b, 7b/ +data (atoibm[l], l = 129, 136) /' ' , '!' , '"' , '#' , '$' , 25b, 6b, 27b/ +data (atoibm[l], l = 137, 144) /'(' , ')' , '*' , '+' , ',' , 11b, 12b, 33b/ +data (atoibm[l], l = 145, 152) /'0' , '1' , 32b, '3' , '4' , '5' , '6' , 10b/ +data (atoibm[l], l = 153, 160) /'8' , '9' , ':' , ';' , 4b, 24b, '>' , 341b/ +data (atoibm[l], l = 161, 168) /'A' , 'B' , 'C' , 'D' , 'E' , 'F' , 'G' , 'H' / +data (atoibm[l], l = 169, 176) /'I' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' / +data (atoibm[l], l = 177, 184) /'X' , 'Y' , 'b' , 'c' , 'd' , 'e' , 'f' , 'g' / +data (atoibm[l], l = 185, 192) /'h' , 'i' , 'p' , 'q' , 'r' , 's' , 't' , 'u' / +data (atoibm[l], l = 193, 200) /'v' , 'w' , 'x' , 200b, 212b, 213b, 214b, 215b/ +data (atoibm[l], l = 201, 208) /216b, 217b, 220b, 232b, 233b, 234b, 235b, 236b/ +data (atoibm[l], l = 209, 216) /237b, 240b, 252b, 253b, 254b, 255b, 256b, 257b/ +data (atoibm[l], l = 217, 224) /260b, 261b, 262b, 263b, 264b, 265b, 266b, 267b/ +data (atoibm[l], l = 225, 232) /270b, 271b, 272b, 273b, 274b, 275b, 276b, 277b/ +data (atoibm[l], l = 233, 240) /312b, 313b, 314b, 315b, 316b, 317b, 332b, 333b/ +data (atoibm[l], l = 241, 248) /334b, 335b, 336b, 337b, 352b, 353b, 354b, 355b/ +data (atoibm[l], l = 249, 256) /356b, 357b, 372b, 373b, 374b, 375b, 376b, 377b/ + +begin + call alutcs (inbuffer, outbuffer, nchars, atoibm) +end + + +# ALUTSC -- Vector operator to map one set of characters to another using a +# lookup table. + +procedure alutsc (a, b, nchars, lut) + +char b[nchars] +int nchars, i +short a[nchars], lut[ARB] + +begin + do i = 1, nchars, 1 + b[i] = lut[a[i] + 1] +end + + +# ALUTCS -- Vector operator to map one set of characters to another using +# a lookup table. + +procedure alutcs (a, b, nchars, lut) + +char a[nchars] +int nchars, i +short b[nchars], lut[ARB] + +begin + do i = nchars, 1, -1 + b[i] = lut[a[i] + 1] +end diff --git a/pkg/dataio/cardimage/mkpkg b/pkg/dataio/cardimage/mkpkg new file mode 100644 index 00000000..63e23fc4 --- /dev/null +++ b/pkg/dataio/cardimage/mkpkg @@ -0,0 +1,13 @@ +# Cardimage library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_rcardimage.x rcardimage.com + t_wcardimage.x wcardimage.com + conversion.x + tabs.x + ; diff --git a/pkg/dataio/cardimage/rcardimage.com b/pkg/dataio/cardimage/rcardimage.com new file mode 100644 index 00000000..064f1af3 --- /dev/null +++ b/pkg/dataio/cardimage/rcardimage.com @@ -0,0 +1,10 @@ +int card_length +int max_line_length +int trim +int entab +int ebcdic +int ibm +char contn_string[SZ_LINE] + +common /rcardcom/ card_length, max_line_length, trim, entab, ebcdic, ibm, + contn_string diff --git a/pkg/dataio/cardimage/structure.hlp b/pkg/dataio/cardimage/structure.hlp new file mode 100644 index 00000000..4a8b5622 --- /dev/null +++ b/pkg/dataio/cardimage/structure.hlp @@ -0,0 +1,139 @@ +.help cardimage Jan85 dataio +.sh +RCARDIMAGE Structure Chart + +.nf +t_rcardimage() +# Returns when file list is satisfied or EOT is encountered. + + cardfile_to_textfile (in_fname, out_fname, nlines, ncards) + + fetchcard (fd, outline, ncards) + # Returns number of chars read or EOF + + card_to_text (fd, instring) + # Returns number of chars or EOF + + conversion routines +.fi + +.sh +WCARDIMAGE Structure Chart + +.nf +t_wcardimage() +# Returns when file list is satisfied. + + textfile_to_cardfile (in_file, out_fname, ncards, nlines) + + fetchline (fd, linebuf, nlines) + # Returns EOF or number of chars read + + text_to_card (line, nchars, card) + + conversion routines +.fi +.sh +RCARDIMAGE Structure Summary + +.ls t_rcardimage +The main procedure reads the control parameters. +The files to be read and converted are calculated from the specified source +and file list. A loop trough the files determines the specific input +and output filenames and calls CARDFILE_TO_TEXTFILE for each conversion. +.ls cardfile_to_textfile +The input and output files are opened. Successive card images are fetched and +converted to text lines by FETCHCARD. If the ENTAB switch is enabled +blanks are replaced by tabs and blanks. +.ls fetchcard +This procedure reads individual card images, optionally joining those +images prefixed by an indentifying continuation string with the previous +card image(s). If trim is enabled white space is removed. Newline and +EOS are added. +.ls card_to_text +Converts a packed card image to a text image. Call the CONVERSION routines +to convert from EBCDIC to ASCII if the ebcdic switch is set. +.le +.le +.le +.le +.sh +WCARDIMAGE Structure Summary + +.ls t_wcardimage +The main procedure read the control parameters. +The files to be read and converted are calculated from the specified +source and file list. A loop through the files determines the specific +input source names and output filenames and calls TEXTFILE_TO_CARDFILE +for each conversion. +.ls textfile_to_cardfile +The input and output source files are opened. Successive text lines are +read and converted to one or more lines card_length + 1 long by +calls to FETCHLINE. +.ls fetchline +FETCHLINE fetches lines of text and splits them into pieces <= +maxch characters long optionally prefixing the remainders with +an identifying continuation string. If the detab switch is set +tabs in the lines are replaced with blanks. +.ls text_to_card +Converts a text string into a packed card image removing the newline +character if necessary and padding with blanks if required. +Call the conversion routines to convert from ASCII to EBCDIC if the +ebcdic switch is set. +.le +.le +.le +.le +.sh +MTEXAMINE Structure Chart + +.nf +t_mtexamine () +# Returns when file list is satisfied + + mtexamine (tape_file, dump_range, byte_chunk, field_len, + vals_per_lines, output_format) + # Returns number of records read + + bytupkl (a, b, nbytes, byte_chunk, byteswap) + + dump (ptr, byte_chunk, nelems, field_len, vals_per_line, + output_format, max_plusint, twice_max_plusint) + + sign_convert (a, nelems, max_plusint, twice_max_plusint) +.fi +.sh +MTEXAMINE Structure Summary +.ls t_mtexamine +T_MTEXAMINE fetches the program parameters and calculates the +input file list. If dump_records is yes, T_MTEXAMINE +calculates the record list to be dumped, calculates the field length +and number of values which can be printed on a line and checks to see that the +data_type and output_format parameters are permitted types. For each +file in the input list T_MTEXAMINE calls MTEXAMINE. +.ls mtexamine +If dump_records is no, MTEXAMINE prints the record structure of the specified +files on the standard output. Otherwise MTEXAMINE loops through the tape +records until it reaches a record number in the record list +and calls dump to output the record to +the standard output. +.ls bytupkl +BYTUPKL unpacks unsigned bytes into and integer array, optionally swaps +the bytes, and assembles byte_chunk bytes into a long integer. +.le +.ls dump +DUMP prints the record on the standard output using the specified +output format and data type. If byte_chunk is 1 the output is unsigned. +If byte_chunk is equal to the size in bytes of a long integer, then +the data will be printed as signed. If byte_chunk is greater than one +and less then the length of a long the data will be signed if the +output format is decimal and unsigned otherwise. DUMP calls twos_comp +to do the sign conversion. +.ls sign_convert +SIGN_CONVERT does a twos complement sign conversion if the output format is +decimal and byte_chunk is greater than one and less than the size of a +long integer. +.le +.le +.le +.le diff --git a/pkg/dataio/cardimage/t_rcardimage.x b/pkg/dataio/cardimage/t_rcardimage.x new file mode 100644 index 00000000..a2dad404 --- /dev/null +++ b/pkg/dataio/cardimage/t_rcardimage.x @@ -0,0 +1,271 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +define MAX_RANGES 100 +define TABSIZE 8 + +# T_RCARDIMAGE -- Procedure to read cardimages tapes. Documentation in +# rcardimage.hlp. + +procedure t_rcardimage() + +char infile[SZ_FNAME] # the input file name list +char outfile[SZ_FNAME] # the output file name list +char file_list[SZ_LINE] # the file number list +int offset # the file number offset +bool join # join long lines ? +bool verbose # verbose output ? + +char in_fname[SZ_FNAME], out_fname[SZ_FNAME] +int nlines, file_number, ncards, range[MAX_RANGES*2+1], nfiles +int lenlist, junk +pointer list + +bool clgetb() +int btoi(), clgeti(), mtfile(), mtneedfileno(), strlen(), decode_ranges() +int get_next_number(), fntlenb(), fntgfnb(), fstati() +pointer fntopnb() +include "rcardimage.com" + +begin + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Get parameters. + call clgstr ("cardfile", infile, SZ_FNAME) + call clgstr ("textfile", outfile, SZ_FNAME) + + # Make up a file list. + if (mtfile (infile) == YES) { + list = NULL + if (mtneedfileno (infile) == YES) + call clgstr ("file_list", file_list, SZ_LINE) + else + call strcpy ("1", file_list, SZ_LINE) + } else { + list = fntopnb (infile, YES) + lenlist = fntlenb (list) + call sprintf (file_list, SZ_LINE, "1-%d") + call pargi (lenlist) + } + + # Decode the ranges. + if (decode_ranges (file_list, range, MAX_RANGES, nfiles) == ERR) + call error (1, "Illegal file number list") + + # Set up the formatting parameters. + card_length = min (SZ_LINE, clgeti ("card_length")) + if (mod (card_length, SZB_CHAR) != 0) + call error (2, "A card must contain an even number of characters") + max_line_length = min (SZ_LINE, clgeti ("max_line_length")) + join = clgetb ("join") + if (join) + call clgstr ("contn_string", contn_string, SZ_LINE) + else + contn_string[1] = EOS + entab = btoi (clgetb ("entab")) + trim = btoi (clgetb ("trim")) + ebcdic = btoi (clgetb ("ebcdic")) + ibm = btoi (clgetb ("ibm")) + if (ibm == YES && ebcdic == YES) + call error (3, "Ibm and ebcdic cannot both be true.") + + offset = clgeti ("offset") + verbose = clgetb ("verbose") + + # Read successive cardimage files, convert and write into a numbered + # succession of output textfiles. + + file_number = 0 + while (get_next_number (range, file_number) != EOF) { + + # Get the input file name. + if (list != NULL) + junk = fntgfnb (list, in_fname, SZ_FNAME) + else { + if (mtneedfileno (infile) == YES) + call mtfname (infile, file_number, in_fname, SZ_FNAME) + else + call strcpy (infile, in_fname, SZ_FNAME) + + } + + # Get the output file name. + call strcpy (outfile, out_fname, SZ_FNAME) + if (nfiles > 1) { + call sprintf (out_fname[strlen(out_fname)+1], SZ_FNAME, "%03d") + call pargi (file_number + offset) + } + + # Copy the cardimage file to the output text file. If a read + # error occurs, try next file. If a zero length file is read, + # meaning that EOT was reached prematurely, merely exit, deleting + # the zero length output file. + + iferr { + if (verbose) { + call printf ("File: %s -> %s: ") + call pargstr (in_fname) + call pargstr (out_fname) + } + + call rc_cardfile_to_textfile (in_fname, out_fname, nlines, + ncards) + + if (verbose) { + call printf ("%d card images -> %d text lines\n") + call pargi (ncards) + call pargi (nlines) + } + + } then { + call flush (STDOUT) + call erract (EA_FATAL) + } else if (nlines == 0) { # EOT reached + if (verbose) { + call printf ("EOT encountered at file %s\n") + call pargi (file_number + offset) + } + call delete (out_fname) + break + } + } + + if (list != NULL) + call fntclsb (list) +end + + +# RC_CARDFILE_TO_TEXTFILE -- Copy a cardfile to a new textfile. +# Outputs the number of cards read and lines written. + +procedure rc_cardfile_to_textfile (in_fname, out_fname, nlines, ncards) + +char in_fname[ARB] # the input file name +char out_fname[ARB] # the output file name +int nlines # the number of lines +int ncards # the number of cards + +char lbuf[SZ_LINE], tempbuf[SZ_LINE] +int in, out, nchars +int mtopen(), open(), rc_fetchcard() +errchk mtopen, open, rc_fetchcard, putline, strentab, close +include "rcardimage.com" + +begin + in = mtopen (in_fname, READ_ONLY, 0) + out = open (out_fname, NEW_FILE, TEXT_FILE) + + ncards = 0 + iferr { + nchars = rc_fetchcard (in, lbuf, ncards) + for (nlines = 0; nchars != EOF; nlines = nlines + 1) { + if (entab == YES) { + call strentab (lbuf, tempbuf, max_line_length, TABSIZE) + call putline (out, tempbuf) + } else + call putline (out, lbuf) + nchars = rc_fetchcard (in, lbuf, ncards) + } + } then + call erract (EA_WARN) + + call close (in) + call close (out) +end + + +# RC_FETCHCARD -- Procedure to read card images and join those images prefixed +# by an identifying continuation string with the previous image(s). +# Returns number of characters in line or EOF. + +int procedure rc_fetchcard (fd, outline, cp) + +int fd # the input file descriptor +char outline[ARB] # the output line +int cp # the card counter + +bool newfile +char instring[SZ_LINE * SZ_SHORT] +int ip, op, npacked_chars, strsize +int rc_card_to_text(), strlen(), strncmp() +errchk rc_card_to_text +data newfile/true/ +include "rcardimage.com" + +begin + ip = 1 + op = 1 + strsize = strlen (contn_string) + + # Get first line of file. + if (newfile) { + npacked_chars = rc_card_to_text (fd, instring) + newfile = false + } + + while (npacked_chars != EOF) { + # Count cards and file output buffer. + while (instring[ip] != EOS && op < max_line_length) { + outline[op] = instring[ip] + ip = ip + 1 + op = op + 1 + } + cp = cp + 1 + + # Check for continuation string in next line, move pointer if yes. + npacked_chars = rc_card_to_text (fd, instring) + + if ((strsize != 0) && + (strncmp (instring, contn_string, strsize) == 0) && + (npacked_chars != EOF)) { + ip = strsize + 1 + } else { + # Output line, remove whitespace, add newline and delimit string + if (trim == YES) + while (op >= 2 && IS_WHITE (outline[op-1])) + op = op -1 + outline[op] = '\n' + outline[op+1] = EOS + return (op) + } + } + + # Initialize for new file. + newfile = true + return (EOF) +end + + +# RC_CARD_TO_TEXT -- Procedure to transform a packed card image to a text image. + +int procedure rc_card_to_text (fd, card) + +int fd # input file descriptor +char card[ARB] # the packed/unpacked cardimage image + +int npacked_chars, nchars +int read() +errchk read, ebcdic_to_ascii, ibm_to_ascii +include "rcardimage.com" + +begin + npacked_chars = read (fd, card, card_length/SZB_CHAR) + if (npacked_chars == EOF) + return (EOF) + nchars = npacked_chars * SZB_CHAR + if (ebcdic == YES) { + call achtbs (card, card, nchars) + call ebcdic_to_ascii (card, card, nchars) + } else if (ibm == YES) { + call achtbs (card, card, nchars) + call ibm_to_ascii (card, card, nchars) + } else + call chrupk (card, 1, card, 1, nchars) + card[nchars+1] = EOS + return (nchars) +end diff --git a/pkg/dataio/cardimage/t_wcardimage.x b/pkg/dataio/cardimage/t_wcardimage.x new file mode 100644 index 00000000..0a85bb55 --- /dev/null +++ b/pkg/dataio/cardimage/t_wcardimage.x @@ -0,0 +1,256 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define TABSIZE 8 + +# Procedure to write cardimage files. See wcardimage.hlp for documentation. + +procedure t_wcardimage() + +char out_file[SZ_FNAME] # input file name list +char in_file[SZ_FNAME] # output file name list +bool verbose # verbose mode ? + +char out_fname[SZ_FNAME] +int ncards, file_number, nlines, list, len_list + +bool clgetb() +int fstati(), clpopni(), clplen(), mtfile(), mtneedfileno() +int clgeti(), clgfil(), strlen(), btoi() +include "wcardimage.com" + +begin + # Flush standard output on newline + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Get the parameters. + list = clpopni ("textfile") + len_list = clplen (list) + + # Get name of output file. + # If no tape file number is given tape output then the program + # asks whether the tape is blank or contains data. + # If it is blank the tape begins writing at file 1 otherwise at EOT. + # Note that at some point this code needs to be modified to + # accept an output file name template. + + call clgstr ( "cardfile", out_file, SZ_FNAME) + if (mtfile (out_file) == YES) { + if (mtneedfileno (out_file) == YES) { + if (! clgetb("new_tape")) + call mtfname (out_file, EOT, out_fname, SZ_FNAME) + else + call mtfname (out_file, 1, out_fname, SZ_FNAME) + } else + call strcpy (out_file, out_fname, SZ_FNAME) + } + + # Get card_length and determine whether it fits in an integral number + # of characters. + + card_length = min (SZ_LINE, clgeti ("card_length")) + if (mod (card_length, SZB_CHAR) != 0) + call error (1, "A card must fit in an integral number of chars.") + + # Get number of cards per physical block and convert to packed chars. + cards_per_blk = clgeti ("cards_per_blk") + + # Get the formatting parameters. + call clgstr ("contn_string", contn_string, SZ_LINE) + if (strlen (contn_string) > card_length) + call error (2, + "Continuation string cannot be > card_length chars.") + detab = btoi (clgetb ("detab")) + + # Get the character type parameters. + ebcdic = btoi (clgetb ("ebcdic")) + ibm = btoi (clgetb ("ibm")) + if (ibm == YES && ebcdic == YES) + call error (3, "Ibm and ebcdic cannot both be true.") + + verbose = clgetb ("verbose") + + file_number = 1 + while (clgfil (list, in_file, SZ_FNAME) != EOF) { + if (mtfile (out_file) == NO) { + if (len_list > 1) { + call sprintf (out_fname[1], SZ_FNAME, "%s%03d") + call pargstr (out_file) + call pargi (file_number) + } else + call strcpy (out_file, out_fname, SZ_FNAME) + } else { + if (file_number == 2) + call mtfname (out_fname, EOT, out_fname, SZ_FNAME) + } + + # Copy text file to cardimage file. + + iferr { + if (verbose) { + call printf ("File: %s -> %s: ") + call pargstr (in_file) + call pargstr (out_fname) + } + + call wc_textfile_to_cardfile (in_file, out_fname, ncards, + nlines) + + if (verbose) { + call printf ("%d lines read -> %d cards written\n") + call pargi (nlines) + call pargi (ncards) + } + } then { + call flush (STDOUT) + call erract (EA_FATAL) + } else if (ncards == 0) { + if (verbose) + call printf ("\tInput file is binary or empty\n") + } + + file_number = file_number + 1 + } +end + + +# WC_TEXTFILE_TO_CARDFILE -- Reads a textfile from disk and outputs a card +# image file to tape or disk. + +procedure wc_textfile_to_cardfile (in_file, out_fname, ncards, nlines) + +char in_file[ARB] # input file name +char out_fname[ARB] # output file name +int ncards # number of card images +int nlines # number of text lines + +char linebuf[SZ_LINE] +int in, out, nchars, chars_per_blk +int mtopen(), open(), access(), wc_fetchline(), mtfile() +errchk mtopen, open, access, wc_fetchline, write, close, wc_text_to_card +include "wcardimage.com" + +begin + nlines = 0 + ncards = 0 + + if (access (in_file, READ_ONLY, TEXT_FILE) != YES) + return + + # Open the file. + in = open (in_file, READ_ONLY, TEXT_FILE) + if (mtfile (out_fname) == YES) { + chars_per_blk = cards_per_blk * card_length / SZB_CHAR + out = mtopen (out_fname, WRITE_ONLY, chars_per_blk) + } else + out = open (out_fname, NEW_FILE, BINARY_FILE) + + # Write file. + nchars = wc_fetchline (in, linebuf, nlines, card_length+1) + while (nchars != EOF) { + call wc_text_to_card (linebuf, nchars, linebuf) + call write (out, linebuf, card_length/SZB_CHAR) + ncards = ncards + 1 + nchars = wc_fetchline (in, linebuf, nlines, card_length+1) + } + + call close (in) + call close (out) +end + + +# WC_TEXT_TO_CARD -- Convert text string into a packed cardimage string +# removing the newline character if necessary, padding with blanks +# if required and optionally translating from ascii to ebcdic or ibm +# ebcdic. + +procedure wc_text_to_card (line, nchars, card) + +char line[ARB] # input text line +int nchars # number of chars in line +char card[ARB] # output packed card image + +int init, ip +errchk ascii_to_ebcdic, ascii_to_ibm, achtsb, chrpak +include "wcardimage.com" + +begin + # Pad with blanks. + init = nchars + if (line[init] != '\n') + init = init + 1 + for (ip=init; ip <= card_length; ip=ip+1) + line[ip] = ' ' + + # Pack the line. + if (ebcdic == YES) { + call ascii_to_ebcdic (line, card, card_length) + call achtsb (card, card, card_length) + } else if (ibm == YES) { + call ascii_to_ibm (line, card, card_length) + call achtsb (card, card, card_length) + } else + call chrpak (line, 1, card, 1, card_length) +end + + +# WC_FETCHLINE -- Procedure to fetch a line of text and split it into pieces +# <= maxch characters long, optionally prefixing the remainders of lines +# with a character string. + +int procedure wc_fetchline (fd, linebuf, lp, maxch) + +int fd # input file descriptor +char linebuf[ARB] # output chunk of text +int lp # number of lines read +int maxch # maximum size of chunk of text + +char line[SZ_LINE], inline[SZ_LINE] +int nchars, ip, op, offset, strsize +int getline(), gstrcpy(), strlen(), strncmp() +errchk getline(), strdetab() +include "wcardimage.com" +data ip /1/ + +begin + # Get new line and detab if requested. + if (ip == 1) { + if (detab == YES) { + nchars = getline (fd, inline) + call strdetab (inline, line, SZ_LINE, TABSIZE) + } else + nchars = getline (fd, line) + if (nchars == EOF) + return (EOF) + + lp = lp + 1 + offset = 0 + strsize = strlen (contn_string) + if (strsize != 0 && strncmp (line, contn_string, strsize) == 0) + call eprintf ("Warning: Line matches continuation string\n") + + } else { + # Otherwise determine length of continuation string. + offset = gstrcpy (contn_string, linebuf, SZ_LINE) + } + + # Copy maxch characters to the output buffer. + op = offset + 1 + while (line[ip] != EOS && op < maxch && line[ip] != '\n') { + linebuf[op] = line[ip] + ip = ip + 1 + op = op + 1 + } + + # Add newline and EOS reset pointer. + linebuf[op] = '\n' + linebuf[op+1] = EOS + if (line[ip] == EOS || line[ip] == '\n') + ip = 1 + + return (op) +end diff --git a/pkg/dataio/cardimage/tabs.x b/pkg/dataio/cardimage/tabs.x new file mode 100644 index 00000000..ccb722a2 --- /dev/null +++ b/pkg/dataio/cardimage/tabs.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRDETAB -- Procedure to remove tabs from a line of text and replace with +# blanks. + +procedure strdetab (line, outline, maxch, tabsize) + +int ip, op, maxch, tabsize +char line[ARB], outline [ARB] + +begin + op=1 + ip=1 + + while (line[ip] != EOS && op <= maxch) { + if (line[ip] == '\t') { + repeat { + outline[op] = ' ' + op = op + 1 + } until ((mod (op, tabsize) == 1) || (op > maxch)) + ip = ip + 1 + } else { + outline[op] = line[ip] + op = op + 1 + ip = ip + 1 + } + } + + outline[op] = EOS +end + + +# STRENTAB -- Procedure to replace blanks with tabs and blanks. + +procedure strentab (line, outline, maxch, tabsize) + +int maxch, tabsize +char line[ARB], outline[ARB] +int ip, op, ltab + +begin + op = 1 + ip = 1 + + repeat { + ltab = ip + while (line[ltab] == ' ' && op <= maxch) { + ltab = ltab + 1 + if (mod(ltab, tabsize) == 1) { + outline[op] = '\t' + ip = ltab + op = op + 1 + } + } + for (; ip < ltab && op <= maxch; ip = ip + 1) { + outline[op] = ' ' + op = op + 1 + } + if (line[ip] == EOS || op >= maxch+1) + break + outline[op] = line[ip] + op = op + 1 + ip = ip + 1 + } until (line[ip] == EOS || op >= maxch+1) + + outline[op] = EOS +end diff --git a/pkg/dataio/cardimage/wcardimage.com b/pkg/dataio/cardimage/wcardimage.com new file mode 100644 index 00000000..4d80adb1 --- /dev/null +++ b/pkg/dataio/cardimage/wcardimage.com @@ -0,0 +1,8 @@ +int card_length +int cards_per_blk +int detab +int ebcdic +int ibm +char contn_string[SZ_LINE] + +common /wcardcom/ card_length, cards_per_blk, detab, ebcdic, ibm, contn_string diff --git a/pkg/dataio/dataio.cl b/pkg/dataio/dataio.cl new file mode 100644 index 00000000..2120892e --- /dev/null +++ b/pkg/dataio/dataio.cl @@ -0,0 +1,19 @@ +#{ The DATAIO data input/output conversion package. + +package dataio + +task rcardimage, + wcardimage, + mtexamine, + txtbin, + bintxt, + rfits, + wfits, + reblock, + rtextimage, + t2d, + wtextimage, + import, + export = dataio$x_dataio.e + +clbye() diff --git a/pkg/dataio/dataio.hd b/pkg/dataio/dataio.hd new file mode 100644 index 00000000..93949ffd --- /dev/null +++ b/pkg/dataio/dataio.hd @@ -0,0 +1,27 @@ +# Help directory for the DATAIO package. + +$doc = "pkg$dataio/doc/" +$fits = "pkg$dataio/fits/" +$reblock = "pkg$dataio/reblock/" +$imtext = "pkg$dataio/imtext/" +$mtexamine = "pkg$dataio/mtexamine/" +$cardimage = "pkg$dataio/cardimage/" +$bintext = "pkg$dataio/bintext/" +$t2d = "pkg$dataio/t2d/" +$import = "pkg$dataio/import/" +$export = "pkg$dataio/export/" + +bintxt hlp=doc$bintxt.hlp, src=bintext$t_bintxt.x +mtexamine hlp=doc$mtexamine.hlp, src=mtexamine$t_mtexamine.x +rcardimage hlp=doc$rcardimage.hlp, src=cardimage$t_rcardimage.x +reblock hlp=doc$reblock.hlp, src=reblock$t_reblock.x +rfits hlp=doc$rfits.hlp, src=fits$t_rfits.x +rtextimage hlp=doc$rtextimage.hlp, src=imtext$t_rtextimage.x +txtbin hlp=doc$txtbin.hlp, src=bintext$t_txtbin.x +wcardimage hlp=doc$wcardimage.hlp, src=cardimage$t_wcardimage.x +wfits hlp=doc$wfits.hlp, src=fits$t_wfits.x +wtextimage hlp=doc$wtextimage.hlp, src=imtext$t_wtextimage.x +t2d hlp=doc$t2d.hlp, src=t2d$t_t2d.x +import hlp=doc$import.hlp, src=import$t_import.x +export hlp=doc$export.hlp, src=export$t_export.x +revisions sys=Revisions diff --git a/pkg/dataio/dataio.men b/pkg/dataio/dataio.men new file mode 100644 index 00000000..3d83ce6b --- /dev/null +++ b/pkg/dataio/dataio.men @@ -0,0 +1,13 @@ + bintxt - Convert a binary file to an IRAF text file + export - Convert IRAF images to some other format + import - Convert some other format to an IRAF image + mtexamine - Examine the structure of a magnetic tape + rcardimage - Convert a cardimage file into a text file + reblock - Copy a binary file, optionally reblocking + rfits - Convert FITS image data into a list of IRAF images + rtextimage - Convert text files to IRAF images + t2d - Fast tape to disk copy + txtbin - Convert an IRAF text file to a binary file + wcardimage - Convert text files to cardimage files + wfits - Convert a list of IRAF images into FITS image data + wtextimage - Convert an IRAF image to a text file diff --git a/pkg/dataio/dataio.par b/pkg/dataio/dataio.par new file mode 100644 index 00000000..ff362077 --- /dev/null +++ b/pkg/dataio/dataio.par @@ -0,0 +1,4 @@ +# Dummy package parameter file. + +version,s,h,"26Apr86" +mode,s,h,ql diff --git a/pkg/dataio/doc/Mtio_notes b/pkg/dataio/doc/Mtio_notes new file mode 100644 index 00000000..c5fb2fe5 --- /dev/null +++ b/pkg/dataio/doc/Mtio_notes @@ -0,0 +1,12 @@ + +MTIO mods: + + (1) Install error checking in MTOPEN ("errchk open"). + + (2) Attempt to position to a file beyond EOT for reading should not + cause an error, rather EOF should be returned at the first read, + indicating a zero length file (i.e., EOT). + + (3) ZARDMT should zero-fill to an integral number of chars, provided + space is available at end of buffer (see ZARDBF, which I had to + modify to provide zero-fill). diff --git a/pkg/dataio/doc/Rfits_notes b/pkg/dataio/doc/Rfits_notes new file mode 100644 index 00000000..7df78ca5 --- /dev/null +++ b/pkg/dataio/doc/Rfits_notes @@ -0,0 +1,85 @@ + +Notes on RFITS program. + +General Comments -- + The code is well structured, modular, and the identifiers are well + chosen for the most part, with some exceptions. I liked the file list + technique, and have incorporated it into the card image reader I wrote + to test MTIO. + + On the critical side, the code is not sufficiently well commented. + A few comments explaining the general approach are needed; the use + of the record buffer, the placement of unrecognized keywords in the + image header, and so on are important things that can only be derived + at present by a very detailed analysis of the code. Functionally the + program has some serious limitations as noted below. + + +Detailed Comments -- + +On functionality: + + (1) Keywords BUNIT, BLANK, DATE, DATE_OBS, ORIGIN, CRVALn, CRPIXn, + etc., etc. should all be recognized. Many of these have direct + complements in the image header and it is merely a matter of + mapping the value directly. Without doing so we cannot save + and restore IRAF images in FITS tape form without serious loss + of information. + + Our intention is eventually to map nonstandard FITS keywords + by name into the user fields. A similar table driven mapping + of the standard fields might therefore be desirable. This + would also make the reader more robust and easier to modify to + read nonstandard or future (extended) formats. + + (2) Something should be done about indefinite pixels. It is easy to + check for FITS BLANK value and map into the appropriate INDEF. + This function should be encapsulated in a separate procedure, + because it will have to be modified when we add bad pixel lists + to IMIO. + + (3) BITPIX=32 is not really implemented. Eight bits of precision lost + is too much. Also, SIMPLE='F' should not result in an irrecoverable + abort; a subsequent program may be able to recover the data if it + can at least be read into an imagefile. For similar reasons, it + would be best if it were possible to move pixels to disk without + conversion. Doing everything in real forces binary conversion of + the pixels, as well as causing the loss of precision for type long. + + +On coding: + + (1) Error checking is only partially implemented. As a rule, low level + procedures should "errchk" all subprocedures which perform i/o, so + that the higher level procedures can decide whether or not they want + to catch errors (makes code easier to modify, i.e., to add an error + handler in the future). + + (2) The stack should be unchanged upon exit from a procedure. SALLOC is + used improperly in several places (noted on listing). + + (3) The constants defining the FITS standard should be parameterized in + an include file with comments, or in an external lookup table. I do + not know what GROUPS, PCOUNT, GCOUNT are, and I had to think a bit to + figure out what the 11, 29, etc. were. The exact version of the + standard implemented by the program should be defined all in one + place, so that others can see what version of the standard is + implemented without having to read and understand the whole program, + and to make it easier to modify the program to read future and + nonstandard "FITS" files. Also numbers like "11", "29" etc. are + inherently hard to understand. Even "80" may have to be changed + to read a nonstandard or improperly written format. + + (4) Defined expressions should be enclosed in parenthesis to guarantee + that they are evaluated properly. The definitions of SZB_BIT, + SZ_UBYTE, etc. do not work if enclosed in parenthesis. This is + very tricky; if I were to inherit the program, I would have "fixed" + those definitions at first sight by adding parens, just to be safe, + and then the code would no longer work. Use of integer division + in expressions where the operands of unknown size is bad. + + (5) The "8" in the definition of SZB_BIT is machine dependent. I have + added an NBITS_BYTE definition to iraf.h. Do not let machine + dependence creep into code!! + + (6) I have added WRDSWP and ACHTB_ to the system libraries. diff --git a/pkg/dataio/doc/bintxt.hlp b/pkg/dataio/doc/bintxt.hlp new file mode 100644 index 00000000..5d758ee5 --- /dev/null +++ b/pkg/dataio/doc/bintxt.hlp @@ -0,0 +1,28 @@ +.help bintxt Jun86 dataio +.ih +NAME +bintxt -- Convert binary files containing only text to text files +.ih +USAGE +bintxt binary_file text_file +.ih +PARAMETERS +.ls binary_file +Input file name or template, e.g. "file1" or "file*". +.le +.ls text_file +The output file name. If multiple input files the filenumber will +be concatenated onto the output file name. +.le +.ls verbose = yes +Print messages of actions performed? +.le +.ih +EXAMPLES +1. Convert a binary file on disk to a text file on disk. + + cl> bintxt binary_file text_file +.ih +SEE ALSO +txtbin +.endhelp diff --git a/pkg/dataio/doc/export.hlp b/pkg/dataio/doc/export.hlp new file mode 100644 index 00000000..4ef4a492 --- /dev/null +++ b/pkg/dataio/doc/export.hlp @@ -0,0 +1,1066 @@ +.help export Oct94 dataio +.ih +NAME +export -- create a binary image file from one or more IRAF images + +.ih +USAGE +export images binfiles + +.ih +PARAMETERS + +.ls images +The list of input IRAF images to be converted. The list may contain +either 2-D images or 3-D images. +Any number of 2-D images may be combined to a single output file, only +one 3-D image (or section) at a time may be converted. See the \fIBuiltin +Formats\fR section for notes about the number of image expressions required +for each builtin format and the handling of 3-D image data. Images greater +than three dimensions should be converted using image sections. +.le +.ls binfiles +The list of output binary files to create. If any of the builtin formats +is selected for conversion the filename will have an extension added +reflecting the format (if it is not already given). +.le + +.ce +OUTPUT PARAMETERS +.ls format = "raw" +The type of binary file to write. If the value is "raw" then the input +images are converted directly to a raw binary raster using the task +parameters. If the value is "list" the pixel values will be written +to the standard output after evaluation of the \fIoutbands\fR parameter in +the same format as would appear from the \fILISTPIX\fR task. Finally, +the value may include any of the currently supported specific builtin formats: + +.nf + eps - Encapsulated PostScript + gif - Compuserve's GIF format + imh - IRAF OIF image + miff - ImageMagick MIFF format image + pgm - PBMPlus PGM format image + ppm - PBMPlus PPM format image + ras - Sun rasterfile format + rgb - SGI RGB format image + xwd - X11 Window dump file +.fi + +If any of these builtin formats is selected one or more of the following +parameters may be ignored. See the \fIBuiltin Formats\fR section for notes +about the formats supported by this task. +.le +.ls outbands = "" +Output image band expressions to write. This is a comma-delimited list of +expressions or an @-file containing the expressions. Evaluated expressions +do not all need to be the same length since the output image will be padded +to the maximum size. See below for more information. +.le +.ls verbose = no +Print verbose output to the screen during conversion? +.le + +.ce +RAW BINARY OUTPUT PARAMETERS +.ls header = yes +For raw binary file output only, prepend a header describing how the data +are stored? If set to "no" then no header will be written. If set to "yes", +a standard text header describing how the data were written will be +prepended to the output file. Setting the \fIheader\fR parameter to the +reserved string "long" will write the image headers from the IRAF images +making up the output file in the standard header. The parameter may also +be set to a filename that will be prepended to the output file. This +parameter is ignored for builtin format output. See below for a description +of the header layout. +.le +.ls outtype = "" +Output pixel type if \fIformat\fR is set to "raw" or "list". This is a +string giving the type and size of each pixel, the syntax for the outtype +entry is +.nf + + [] +where + type = b # byte + u # unsigned (short) integer + i # signed integer + r # ieee floating point + n # native floating point + + nbytes = 1, 2, 4, or 8 + +.fi +If no value for \fInbytes\fR is given the smallest size for the given type +(i.e. 1 byte for 'b', 2 bytes for ints, 4 bytes for floating point) will +be used. If no value is entered at all the type of the input image is used, +for multiple images used to create a single binary file the type of the first +image is used. This parameter is ignored for builtin format output options. +.le +.ls interleave = 0 +Pixel interleave type. If the \fIoutbands\fR parameter is composite +(i.e. a comma-delimited list of expressions) the output file is pixel +interleaved and the \fIinterleave\fR parameter is ignored. If the +\fIoutbands\fR parameter is a single expression the file is line-interleaved +when the \fIinterleave\fR value is a positive integer. If the \fIoutbands\fR +is an empty string or a single expression the binary file is band interleaved +if this parameter is zero. This parameter is ignored for builtin formats +where the pixel storage is predefined. +.le +.ls bswap = "no" +Type of byte-swapping to perform on output. The default is bswap=no which +may be abbreviated "bswap-" (similarly a value of 'yes' can be abbreviated +"bswap+"). If disabled no byte-swapping is performed, if set all integers +are swapped on output relative to the current machine's byte ordering. +Values of 'i2' or 'i4' will swap only two or four byte integers respectively, +floating point values remain unswapped. This parameter may be used by some +builtin formats that don't have a specified byte order. +.le + +.ih +DESCRIPTION + The \fIexport\fR task will convert one or more images in an +input list to a binary raster file, a text listing of pixels values, +or one of several specific file formats. For general binary +rasters, various pixel types, data interleaving, and the byte order can be +specified. An optional header may be added to the output file. +Arbitrary arithmetic expressions, using both standard and custom +functions, may be applied to the images in the +input list before conversion allowing the user to scale intensity values, +change image orientation, compute colormaps, or compute output pixel +values. + + The \fIformat\fR parameter controls the type of output generated: +if set to \fIraw\fR a binary file described by the \fIouttype\fR, +\fIinterleave\fR, and \fIbswap\fR parameters is written with pixel values +determined from the expressions in the +\fIoutbands\fR parameter. The value of \fIouttype\fR +defines the output pixel size and type (long or short ints, native or IEEE +reals, see parameter description for details). The +\fIbswap\fR parameter can be used to set the byte order (relative to the +current machine) of integer values, this +parameter is ignored for floating point pixels or builtin +formats with a specified byte order. The \fIoutbands\fR and \fIinterleave\fR +parameters define the pixel storage in the binary file. For multiple +\fIoutbands\fR +expressions the data are assumed to be pixel interleaved (e.g. written +as { {RGB}, {RGB} ...} triplets). For single expressions, a positive value +of \fIinterleave\fR indicates that the data are written in a line-interleaved +manner (e.g. a line of R, a line of G, ...). If \fIinterleave\fR is +zero and \fIoutbands\fR is a single expression +then no interleaving is done and the image bands are written sequentially. +If \fIoutbands\fR is the null string, all pixels in a single input image +will be written to a single output file. +Error checking is done to make sure the combination of these +parameters is correct. If the \fIheader\fR parameter is "yes" a text header +describing how the data were written will be prepended to the file, setting +the \fIheader\fR parameter to the reserved string "long" +will cause the image header for each input image +to be saved in the standard header. The \fIheader\fR parameter may also +be the name of a user-defined file to prepend to the output instead of the +standard header. + + If the \fIformat\fR parameter is set to "list" the pixels values +will be written to the screen as an ascii list of pixel coordinates +followed by the pixel value. Pixel coordinates are determined using the +same interleaving scheme as above, values are determined by evaluating +each \fIoutbands\fR expression. + + Lastly, the \fIformat\fR parameter may be any of the currently +supported builtin formats. See the section on \fIBuiltin Formats\fR for +more information and the restrictions or requirements of each format. + +.ih +MORE ON OUTBANDS EXPRESSIONS + The simplest specification for \fIoutbands\fR is a null string, +in which case the image is converted directly (i.e. band storage, +pixels converted to output type). Arbitrary interpreted arithmetic +expressions using standard and custom functions and operators are also +supported. If the \fIimages\fR parameter is a list of 3-D images the +operand names are the predefined tags b1, b2, ... bN for the bands in each +image, the \fIbinfiles\fR parameter must contain an equal number of +output files. To convert multiple 3-D images they must either be sliced +to individual 2-D images (or specified as image sections) or stacked into +a single image. If the \fIimages\fR parameter is a list of 2-D images +(or sections) the operand names are the predefined tags i1, i2, ... iN for +the each image in the input list, the b1, b2, etc names are also recognized. +For more complex or +lengthy expressions the \fIoutbands\fR parameter may alternatively be an +@-file containing the expressions. Within this @-file whitespace and +newline characters are ignored to allow expressions to be indented in a +readable manner. + + The image operands determine which input images in the list are +converted to which output files. For 3-D input images one IRAF image is +converted for each output file in the list, for 2-D images multiple images +may be converted to a single output file. In the latter case the list +pointers are updated automatically to keep track of the images. For example, +to convert six images to two output files, the \fIoutbands\fR expression +should contain three images operands. The first three images in the list +will be used in evaluating the expressions for the first output file, +the last three for the second file. + + The image tags may be reordered in the expression but still refer to +e.g. band-1, band-2 and so on. For example (where rgbim is a 512x512x3 image, +and rim, gim, and bim are 512x512 images), + +.nf +cl> export rgbim file outtype="u2" header- (1) +cl> export rgbim file outtype="u2" header- outbands="b3,b2,b1" (2) +cl> export rim,gim,bim file outty="u2" outbands="i3,i2,i1" (3) +cl> export rim,gim,bim file outty="b" outbands="gray(i1,i2,i3)" (4) +.fi + +Example (1) converts the input image pixels to a raw binary file of +unsigned short integers with no header written as one image band following +another. In example (2) the order of the bands is reversed and the binary +file is stored as pixel interleaved BGR triplets of short ints. +Example (3) is the same as (2) except that the input images in the list +are reordered instead of bands within a single image. When using the image +tags the input list is updated to account for this, so it is allowed to have +more input images than output binary files. +In example (4) the three images are converted to a single grayscale image +before being written as byte data to the binary file. +More complex and detailed examples are given below. + +Individual \fIoutbands\fR expressions are composed of operators and operands +in general interpreted arithmetic expressions as follows: + +\fBOperands\fR +.nf + + iN # image list item + iN.param # image parameter + @"param" # parameter of 3-D image + bN # band within 3-D image + + func() # function + constant # numeric constant +.fi + + The 'iN.param' and '@"param"' syntax allows an image header parameter +to be accessed. For example 'i2.otime' refers to the 'otime' image +header parameter in the second image of a list and '@"otime"' refers to the +current image if the input list contains 3-D images. They may +be used in an outbands expression such as +.nf + + (i1*(i1.otime/i2.otime)),i2,(i3*(i3.otime/i2.otime)) (1) + (b1/@"otime")),(b2/@"otime"),(b3/@"otime") (2) + +.fi +to normalize the output bands by the exposure time value in the second image +in the first example, or to normalize by the 'otime' keyword of a 3-D image +in the second example. + + In cases where a constant value is used as an outbands expression an +alpha channel (an extra 8-bits of constant intensity) will be created +consisting of that value. For example, writing a 32-bit RGB image with an +alpha channel of 255 could be written using + + cl> export rgbim file outtype="b1" outbands="b1,b2,b3,255" + + +\fBOperators\fR + +The expression syntax implemented by \fIexport\fR provides the following +set of operators: + +.nf + + ( expr ) - grouping + + - * / - arithmetic + ** - exponentiation + // - concatenate + expr ? expr1 : expr2 - conditional expression + + && - logical and + || - logical or + ! - logical not + < - less than + <= - less than or equal + > - greater than + >= - greater than or equal + == - equals + != - not equals + ?= - substring equals +.fi + +The conditional expression has the value \fIexpr1\fR if \fIexpr\fR is true, +and \fIexpr2\fR otherwise. Since the expression is evaluated at every pixel +this permits pixel-dependent operations such as checking for special pixel +values, or selection of elements from either of two vectors. For example, +the command + + (i1 <= 0) ? 0 : 1 + +has the constant value zero if "i1" is less than or equal to zero, +and one otherwise, effectively creating a pixel mask of positive pixels. +Conditional expressions are general expressions and may be nested or used +anywhere an expression is permitted. + +The concatenation operator applies to all types of data, not just +strings. Concatenating two vectors results in a vector the +combined length of the two input vectors. An example use of this would +be to concatenate images side-by-side on output. + + +\fBSpecial Functions\fR + + In addition to the intrinsic functions already provided (see the help +page for the \fIimexpr\fR task for a list of standard, mathematical and type +conversion functions) there are a number of custom functions for this task: + +.ce +\fBOutput Functions:\fR + +.nf + band (args) - force band interleaved storage + line (args) - force line interleaved storage + flipx (args) - flip image in X dimension + flipy (args) - flip image in Y dimension + + block (val,width,height) - block fill area with a constant +.fi + + These functions define how the output data are written. For builtin +formats whose normal orientation and storage format is known these functions +are ignored (except where noted). These functions may not be used as arguments to other functions (except where noted) or as single operands +within expressions (e.g. "255 + flipx(i1)"), however their arguments may +be expressions or (perhaps output) functions themselves. + +.ls band (args) +Force band storage in the output file regardless of the value of the +\fIinterleave\fR parameter. This may be used to specify multiple +expressions for each band while still forcing band storage (the default +for multiple expressions is pixel-interleaved storage). This function +may be used with some builtin formats to write multiple images to the output +file as if they were a column of images in the original. This function +is ignored by builtin formats that do not support this scheme (i.e RGB +format) and may be used as an argument to the \fIsetcmap()\fR, \fIpsdpi()\fR, +and \fIpsscale()\fR functions only. +.le +.ls line (args) +Force line storage in the output file regardless of the value of the +\fIinterleave\fR parameter. This may be used to specify multiple +expressions for each band while still forcing line storage (the default +for multiple expressions is pixel-interleaved storage). This function +is ignored by builtin formats that do not support this scheme. +.le +.ls flipx (args) +Flip the image left-to-right on output. This function may be used as an +argument to the \fIband()\fR, \fIsetcmap()\fR, \fIpsdpi()\fR, or +\fIpsscale()\fR functions only. +.le +.ls flipy (args) +Flip the image top-to-bottom on output. Certain builtin formats (such as +GIF, PGM, PPM, RAS and XWD) have their normal orientation already flipped wrt +to IRAF and these will automatically be flipped on output. Using this +function with those formats cancels the flip action, writing the image in the +normal IRAF orientation and not the normal format orientation. +This function may be used as an argument to the \fIband()\fR, \fIsetcmap()\fR, +\fIpsdpi()\fR, or \fIpsscale()\fR functions only. +.le +.ls block (value, width, height) +Fill an area with a constant value. This function can be used to fill a +vertical area between images to provide padding of a constant value. It +is similar to the "repl()" intrinsic function which replicates a data element +a given number of times. +.le + + +.ce +\fBScaling Functions:\fR +.nf + + zscale (arg [,z1, z2 [, nbins]]) - scale to a fixed number of bins + zscalem (arg1, arg2) - automatic scaling with filtering + gr[ea]y (arg1,arg2,arg3) - RGB to grayscale conversion + bscale (arg, zero, scale) - linearly transform intensity scale + gamma (arg, gamma [, scale]) - apply a gamma correction +.fi + + These functions may be used to scale the intensity values of the +image before output in order to map image datatypes to a specified range. +The 'args' value may be a list of image operands or expressions. These +functions may be used as arguments to the output functions above +or as operands within more complex expressions. + +.ls zscale (arg [,z1,z2 [,nbins]]) +Scale the pixels in a given range to a specified number of bins. This +function will map the input pixels within the range z1 to z2 to one of +'nbins' values. Pixels less than z1 are mapped to the lowest output +intensity value, pixels greater than z2 are mapped to the highest value. +If no \fIz1\fR and \fIz2\fR arguments are given appropriate values will +be computed using the same algorithm and default parameters used by +the \fIDISPLAY\fR task (see the help page for more information). +If no \fInbins\fR value is given 256 bins are assumed. + +If the given value of z1 is greater than z2 the mappings will be inverted, +i.e. larger pixel values will map to the lower bin numbers, smaller pixel +values will map to larger bin numbers. For example, to map the dev$pix +test image to 200 colors such that there are "black" stars on a "white" +background one could use +.nf + + zscale (b1, @"i_maxpixval", @"i_minpixval", 200) +.fi +.le +.ls zscalem (arg1, arg2) +This is a variant of the zscale operand with automatic scale calculation; +i.e. zscale (arg). The first argument is the same as for zscale to select +the pixel values. The second argument is a boolean (true or false) +expression selecting whether a value in the first argument is to be used in +the calculation. This allows limiting the automatic scale calculation to +pixels specified in a mask or to a certain range to exclude extreme or bad +values that would otherwise perturb the result. Typical usages might be +.nf + + zscalem (i1, i2==0) + zscalem (i1, i1>0&&i1<10000) +.fi +where i1 are the image pixels and i2 would be pixels from the second +input argument which defines a mask. Note that you can't just say i2 +for a mask but must use it in an expression resulting in a true or false +value. Also note that the result is always in the range 0 to 255. +.le +.ls grey (arg1,arg2,arg3) or gray (arg1,arg2,arg3) +Convert three image operands or expressions to a single grayscale image +using the standard NTSC equation: +.nf + + Gray = 0.3 * arg1 + 0.59 * arg2 + 0.11 * arg3 +.fi +.le +.ls bscale (arg, zero, scale) +Linearly transform the intensity scale of the image using the equation +.nf + + new[i] = (arg[i] - zero) / scale + +.fi +Pixels are scaled in their input datatype prior to converting to the output +datatype. +.le +.ls gamma (arg, gamma [, scale]) +Apply a gamma correction to the pixels. Pixel values are scaled according to +the equation +.nf + + new = scale * [ (old/scale) ** (1.0/gamma) ] + +.fi +If no scale argument is given a value of 255 will be assumed. +.le + + + \fIAdditional functions\fR are supported for specific formats: + +.nf + Function Description Formats + -------- ----------- ------- + cmap (r,g,b [,ncols]) create 8-bit colormap GIF,RAS,XWD,EPS + setcmap (args, [opts]) define a colormap GIF,RAS,XWD,EPS + psdpi (args, dpi) set dpi for output EPS + psscale (args, scale) set scale of output EPS +.fi + + These functions may take as arguments some of the output functions +named above. For example, one can specify the dpi resolution of EPS output +and band storage of images using something like +.nf + + psdpi(band(args), dpi) + +.fi + +.ls cmap (arg1,arg2,arg3 [, ncolors]) +Compute an 8-bit colormap from three image operands or expressions using a +Median-Cut Algorithm and Floyd-Steinberg dithering. The computed colormap +is written to the header of the output file. The resultant image +is an 8-bit color index into the computed colormap. The \fIncolors\fR argument +specifies the number of desired colors, a default value of 256 will be used +if not provided. This function is only +allowed for builtin formats supporting color lookup tables and may not be +used within another expression or function. +.le +.ls setcmap (args, cmap [, brightness, contrast]) +Define the colormap to be used on output. This function is only supported +for formats that support colormaps, the \fIargs\fR expressions are used to +compute the color index values. The \fIcmap\fR argument may either be the +filename of a normalized colormap table (such as is used by \fIXImtool\fR) +or one of the builtin values: +.nf + aips0 - and RGB false color mapping + blue - various shades of blue + color - standard B/W and RGB colormap + grayscale - standard grayscale + greyscale - (alias for above) + green - various shades of green + halley - standard halley mission colormap + heat - temperatures as colors + rainbow - rainbow colors + red - various shades of red + staircase - RGB staircase + standard - RGB ramps + overlay - grayscale with IMDKERN overlay colors +.fi + +Colormap names must be quoted with either single or double quote characters. +The optional \fIbrightness\fR and \fIcontrast\fR arguments have default +values of 0.5 and 1.0 respectively corresponding to the default +brightness/contrast scaling of the \fIXImtool\fR display server. +If the cmap argument is an empty string the default Grayscale LUT will +be used, IRAF logical paths may be used in the filename specification. +.le +.ls psdpi (args, dpi) +Specify the dots-per-inch resolution of the output image. The default +resolution is 300dpi, this may need to be reset for some printers or if +the raster rendering produces "bands" in the output. This function may +only be used as an argument to the \fIpsscale()\fR function. +.le +.ls psscale (args, scale) +Specify the scale of the output image. The default value is 1.0 which +means that image printed on a 300dpi device is roughly the same size +as displayed on a typical 72dpi screen. Scale values less than one reduce +the image size on the page, values greater than one increase the size. The +scale value will automatically be adjusted if it creates an image that will +not fit on a 8.5 inch by 11 inch page. A scale value of 0.25 prints one +image pixel per 300dpi printer pixel. This function may +only be used as an argument to the \fIpsdpi()\fR function. +.le + +.ih +EXPORT HEADER FORMAT + The header prepended to the binary data is ascii text consisting of +keyword-value pairs, one per line, terminated with a newline after the +value, beginning with the magic string +"format = EXPORT". Using an ascii header allows the file format to be +easily determined by the user with a file pager or any program reading +the file. + +Defined keywords are: + +.nf + date - date file was written (dd/mm/yy) + hdrsize - size of header (bytes) + ncols - no. of image columns + nrows - no. of image rows + nbands - no. of image bands + datatype - pixel type (as ) + outbands - outband expression list + interleave - interleave value (same as above) + bswap - are ints swapped relative to MII format? + image1 - image names used in creating file + : + imageN + header1 '{'
'}' - image headers of above + : + headerN '{'
'}' + end - terminate header +.fi + +If the \fIheader\fR parameter is set to "long" the image headers for +each image used in creating the file is included in the output header, +otherwise only the image names are included. + +A sample (verbose) header might look like: + +.nf + format = EXPORT + date = '19/06/94' + hdrsize = 2084 + nrows = 512 + ncols = 512 + nbands = 1 + datatype = 'i2' + outbands = '' + interleave = 0 + bswap = no + image1 = "dev$pix" + header1 = { + IRAF-BPX= 16 / DATA BITS/PIXEL + IRAFTYPE= 'SHORT ' / PIXEL TYPE + CCDPICNO= 53 / ORIGINAL CCD PICTURE NUM + ITIME = 600 / INTEGRATION TIME (SECS) + : : : : + } + end +.fi + +.ih +BUILTIN FORMATS + While the task provides a way of writing general binary raster +files there is still a need for converting to specific formats. +Implementing most formats is trivial since they usually follow the +data model and the only "builtin" knowledge of the format is the minimal +header required. More complex formats such as GIF and EPS are implemented +as special cases. Note that all of the builtin formats require 8-bit color +index or 8-bits per color in RGB or RGBA files, users should be careful +in how the datatype conversion from IRAF image types is handled. In most +cases this can be handled with the \fIzscale()\fR or \fIzscalem\fR functions. + + For each of the formats listed below the table shows the number +of \fIoutbands\fR expressions required and the type of output file that +can be written. Complete examples for the most common cases are shown in +the \fIExamples\fR section below. The columns in the table are defined as +.nf + + #expr - number of required \fIoutbands\fR expressions + Type - RGB or 8-bit colormap (index) file + bitpix - number of bits-per-pixel + CLT? - does the file have a colormap? + Alpha? - does the file have an alpha channel? + Interleaving - type of pixel interleaving + Notes - see explanation below each table + +.fi +A general description and specific restrictions or requirements are given for +each format. An error is generated of the input parameters do not meet the +requirements of the requested format. Unless otherwise noted the values of +the \fIheader\fR, \fIbswap\fR and \fIinterleave\fR parameters will be ignored. +The value of \fIouttype\fR will be set internally and is also ignored. + + If the input image is 3-D and no \fIoutbands\fR expressions are +given, then where supported each band will be written to the output file as +a complete image or RGB color component. For example, a 512x512x3 image +will be written as a 512x1536 image with each band comprising one third +the height of the output image. If the output format requires 24-bit pixels +then each band of the image will be written as a color component. + + The currently supported builtin formats include: + +.ls EPS - Encapsulated PostScript +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 no no none + +.fi + The output 8-bit Encapsulated PostScript image +centered on the page at a default scale of 1.0 at 300dpi (i.e. the image will +appear on a 300dpi printer about the same size as displayed on a 72dpi +screen). The output scale may be adjusted using +the \fIpsscale()\fR function, e.g. to set the output for one image pixel +per 300 dpi printer pixel use "psscale(b1,0.25)" (one quarter the normal size +on the page). The output dpi resolution may be set explicitly with +the \fIpsdpi()\fR function, this is sometimes necessary if "bands" appear +in the final output image. Color EPS files may be written as either RGB +postscript or with a colormap applied to the data (using either the +\fIcmap()\fR or \fIsetcmap()\fR functions). +.le +.ls GIF - Compuserve's GIF format +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 yes no none 1 + 3 index 8 yes no none 2 + + Notes: + 1) Colormap generation enabled using \fIsetcmap()\fR or else + default grayscale colormap will be used + 2) use of \fIcmap()\fR required to generate colormap + +.fi + The output file is a GIF '87 image. A linear colormap of 256 entries +will automatically be generated if only one image or expression is given for +conversion and no colormap is specified. +If three images or expressions are specified a 24-to-8 bit +conversion can be done using a Median Cut Algorithm and Floyd-Steinberg +dithering with the required \fIcmap()\fR function. Since the colormap +sizes are limited to 256 entries the maximum pixel value is assumed to +be 255, i.e. the output pixel size will be forced to 8-bits or less. +.le +.ls IMH - IRAF image file + The output file is an IRAF OIF format image of the specified datatype. +Writing the image out as another IRAF image may be used to scale or composite +several images into a new image that can be annotated with the \fITVMARK\fR +task before writing out the final format. +.le +.ls MIFF - ImageMagick MIFF format image +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 no no none + 1 index 8 yes no none 1,2 + 3 rgb 24 no no pixel + + Notes: + 1) Colormap generation enabled using \fIsetcmap()\fR + 2) Colormap generation enabled using \fIcmap()\fR + +.fi + The output file is a Machine Independent File Format image, with or +without a colormap or as a 24-bit RGB image. Although MIFF permits 64K +colors in a colormap the task only supports 256 colors, no compression is +used in the image. The maximum pixel value per color is assumed to be 255. +.le +.ls PGM - PBMPlus PGM format image +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 no no none + 3 index 8 no no none 1 + + Notes: + 1) Grayscale may be produce with \fIgray()\fR function + +.fi + The output file is an 8-bit raw (i.e. binary pixels) PGM image. +The maximum pixel value is assumed to be 255. +.le +.ls PPM - PBMPlus PPM format image +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 3 rgb 24 no no pixel + +.fi + The output file is an 24-bit raw (i.e. binary pixels) PPM image. +The maximum pixel value per color is assumed to be 255. +.le +.ls RAS - Sun rasterfile format +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 no no none + 1 index 8 yes no none 1,2 + 3 rgb 24 no no pixel + 4 rgb 32 no yes pixel + + Notes: + 1) Colormap generation enabled using \fIsetcmap()\fR + 2) Colormap generation enabled using \fIcmap()\fR + +.fi + The output file will be a Sun rasterfile. The header values +(long integers) may be byte swapped by setting the \fIbswap\fR parameter +to "yes" or "i4". For 32-bit true-color rasterfiles the +alpha channel should be specified as the first expression. The maximum +pixel value is assumed to be 255. +.le +.ls RGB - SGI RGB format image +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 no no none + 3 rgb 24 no no scanline + +.fi + The output file will be an SGI RGB (IRIS) format image. Although +this format supports colormaps they are not supported by this task. +The maximum pixel value is assumed to be 255. +.le +.ls XWD - X11 Window dump file +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 yes no none 1,2,3 + 3 rgb 24 no no none + + Notes: + 1) Linear grayscale colormap automatically generated + 2) Colormap generation enabled using \fIsetcmap()\fR + 3) Colormap generation enabled using \fIcmap()\fR + +.fi + The output file will be an X11 window dump file. +A linear colormap of 256 entries will automatically be generated if only +one image or expression is given for conversion, the \fIsetcmap()\fR function +may be used to create an alternate colormap. If three images or expressions +are specified a 24-to-8 bit conversion can be done using a Median Cut +Algorithm and Floyd-Steinberg dithering if the \fIcmap()\fR function is +specified. Header values (long integers) may be byte swapped by setting the +task \fIbswap\fR parameter to "yes" or "i4". The maximum pixel value is +assumed to be 255. +.le + +.ih +COLOR OUTPUT IMAGES + In theory the colormaps generated by the \fIcmap()\fR and +\fIsetcmap()\fR functions could be written in the header for raw binary +output and the pixel written out as color indices, but since we also +support color index formats which are recognized widely by other packages +there is no need to do this. Therefore we limit the use of colormaps to +the builtin formats which already support it. + + The simplest type of "color" image is the familiar grayscale image. +Pixel values represent the display gray level, although for some formats a CLT +(color lookup table) is required (e.g. GIF) and these pixel values are +actually indices into a grayscale colormap. Most of the conversion done +with this task will produce a grayscale image of some sort. For "color +index" images the pixel values are indices into a colormap containing the +RGB components of the color for a pixel with that value. Colormaps +usually permit at most 256 possible colors implying 8-bit pixels. +In this task the colormap may be computed either with the \fIcmap()\fR (which +does a 24-to-8 bit mapping of the colors) or the \fIsetcmap()\fR function +(which computes the colormap from a display lookup table of colors). +"True color" images are those which have 24-bits of color (8-bit for each +component) for each pixel, some true color images also contain an alpha +channel (an extra 8-bits of constant intensity) which may or may not be +used by the software displaying the image. + + The \fIcmap()\fR function takes three images and computes a colormap +using Paul Heckbert's Median Cut Algorithm ("Color Image Quantization for +Frame Buffer Display", SIGGRAPH '82 Proceedings, pg 297) and Floyd-Steinberg +dithering technique. The computed colormap is written to the file header +and pixel values are converted to color indices. By default 256 colors are +computed but fewer colors may be requested. This function is most useful +for generating pseudo-color images from three input images taken in different +filter bands (which is required for some formats like GIF that do not +support 24-bit RGB). + + The \fIsetcmap()\fR function, on the other hand, can be used to +generate a color image from a single input image and a lookup table such as +the ones used by displays servers like XImtool. In this case the pixel +values are indices into a pre-defined colormap which is normalized between +zero and one (so that it may be scaled to the desired number of colors). +The \fIbrightness\fR argument defines the center of the transfer function, the +default is 0.5 because it in the middle of the normalized range. The +\fIcontrast\fR arguments sets the contrast of the transfer function. For +example, the normalized pixel values and default brightness/contrast settings +will map the pixel values to the corresponding color in the LUT. Changing +the brightness to a lower value means that pixel intensities will map to lower +values in the LUT, doubling the contrast for instance means that the LUT +will increment two colors for every unit pixel change. This is what happens +when changing a displayed image in IRAF with the mouse by moving the cursor +left-right (changing the brightness) or up-down (changing the contrast). + + An example use of this function would be if one wanted to convert an +IRAF image to a color rasterfile with the same colormap and intensity +scaling as was displayed in XImtool. After adjusting the display the +brightness/contrast values could be read from the control panel and the +rasterfile generated using +.nf + + setcmap (b1, "aips0", 0.36, 1.2) + +.fi +where the "aips0" is one of the builtin colormaps and the brightness and +contrast arguments are those from the ximtool display. Similarly, the +expression +.nf + + setcmap (zscale(i1),"idl15.lut") + +.fi +will save the image with the same intensity scaling and color as would be see +by displaying it to ximtool using the default DISPLAY task settings, +normalized XImtool brightness/contrast values and the "idl15.lut" LUT in the +current directory. + + +.ih +EXAMPLES + The examples below are divided into several categories showing +typical usage when creating various raw and builtin output files. Note +that the output file will have a filename extension added indicating the +format when converting to a builtin format. + +\fICreating Raw Binary Files\fR +.nf + +List the pixels being one the standard output, apply a linear scale +function first: + + cl> export dev$pix "" list outbands="bscale(b1,1.0,3.2)" + +Convert the dev$pix test image to an 8-bit binary file with a gamma +correction, write the standard header: + + cl> export dev$pix bfil raw header+ outty="u1" outbands="gamma(b1,1.8)" + +Write the three bands of an IRAF image to a pixel interleaved binary +file of short integers, prepend a user-defined header: + + cl> export rgbim bfil raw header="hdr.txt" outty="i2" outban="b1,b2,b3" + +Convert three images representing RGB to a 4-color line-interleaved +file, the IRAF images don't require scaling, create alpha channel: + + cl> export rim,gim,bim bfil raw outty="u1" outban="line(i1,i2,i3,0)" + +Write the three bands of an IRAF image to a line-interleaved binary +file of short integers: + + cl> export rgbim binfil raw outtype="i2" outbands="line(b1,b2,b3)" + cl> export rgbim binfil raw outtype="i2" outbands="" interleave=3 + +Write the three bands of an IRAF image to a grayscale binary file using +a custom conversion formula. Pixel values are truncated to 8-bits: + + cl> export rgbim grey raw outty="u1" outban="(.2*b1)+(.5*b2)+(.3*b3)" + +.fi + +\fICreating Specific Formats\fR +.nf + +Convert dev$pix to an 8-bit Sun rasterfile with no colormap, scale the +image to 8-bits using the default \fIzscale()\fR intensity mapping: + + cl> export dev$pix dpix ras outbands="zscale(i1)" + +Apply various functions to the data before doing the same conversion: + + cl> export dev$pix dpix ras outbands="zscale(log(i1))" + cl> export dev$pix dpix ras outbands="zscale(sqrt(i1))" + +Convert dev$pix to an 8-bit Sun rasterfile with no colormap, image pixel +values are truncated to 8-bits: + + cl> export dev$pix dpix ras + +Convert three images representing RGB to a 24-bit Sun rasterfile, assume +the IRAF images don't require intensity scaling: + + cl> export rim,gim,bim rgb ras outbands="i1,i2,i3" + +Create a Silicon Graphics RGB format image from a 3-D image: + + cl> export rgbim bdata rgb outbands="b1,b2,b3" + +Convert dev$pix to an 8-bit GIF grayscale image, scale the image to map +only pixel values between 0 and 320: + + cl> export dev$pix dpix gif outbands="zscale(i1,0.0,320.0)" + +Combine three images representing RGB into an 8-bit X11 window dump +grayscale image: + + cl> export rim,gim,bim gray xwd outbands="gray(i1,i2,i3)" + +Convert dev$pix to an Encapsulated PostScript file at half the normal scale +and apply a linear transformation to scale the pixel values: + + cl> export dev$pix dpix eps \ + >>> outbands="psscale(bscale(i1,0.,0.32), 0.5)" + +Convert three images representing RGB to an 8-bit GIF color image with +a computed colormap: + + cl> export rim,gim,bim rgb gif outbands="cmap(i1,i2,i3)" + +Convert dev$pix to a color rasterfile using the builtin "heat" colormap +and default intensity mapping: + + cl> export dev$pix dpix ras outban='setcmap(zscale(i1),"heat")' + +Convert dev$pix to a color rasterfile using the XImtool "idl15.lut" +LUT file in the current directory and default intensity mapping: + + cl> copy /usr/local/lib/imtoolcmap/idl15.lut . + cl> export dev$pix dpix ras outbands="setcmap(zscale(i1),'idl15.lut')" + + +\fIAdvanced Usage\fR + +Given a set of DISPLAY task z1/z2 values of 10 and 320 respectively, and +brightness/contrast values from XImtool of 0.6 and 1.2 respectively, +convert an image to an EPS file with the same appearance: + + im> type expr + setcmap ( zscale (i1, 10.0, 320.0), "greyscale", 0.6, 1.2 ) + im> export dev$pix dpix eps outbands="@expr" + +Concatenate two images side-by-side to a PGM file, normalize each image +by it's exposure time and apply a default intensity mapping: + + cl> export im1,im2 two pgm \ + >>> outbands='(zscale(i1/i1.otime)) // (zscale(i2/i2.otime))' + +Convert dev$pix to a color GIF using the XImtool "idl15" LUT with a spec- +ified brightness/contrast scale. Map only pixel values between 5 and 300 +to 201 output intensity values. This should produce and image identical +to what one would get by displaying dev$pix to imtool, setting the same +brightness/contrast scale, and selecting the idl15 LUT: + + cl> copy /usr/local/lib/imtoolcmap/idl15.lut . + cl> type expr.dat + setcmap ( + zscale(i1, 5.0, 320.0, 201), + "idl15.lut", + 0.41, + 1.35) + cl> export dev$pix dpix gif outbands="@expr.dat" + +Combine three images representing RGB to an 8-bit Sun rasterfile with a +computed colormap. Scale the intensity value of each image differently. + + cl> type expr.dat + cmap ( + zscale (i1), + zscale (i2, 0.0, 1200.0), + zscale (i3, -1.0, 320.0) ) + cl> export im1,im2,im3 rgb ras outbands="@expr.dat" + +Do the same example but apply a gamma correction to the images: + + cl> type expr.dat + cmap ( + gamma (zscale(i1), 2.2), + gamma (zscale(i2,0,1200), 2.2), + gamma (zscale(i3,-1,320), 2.2) ) + +Write four images to a grayscale GIF file such that they are tiled in a +2x2 grid: + + cl> export im1,im2,im3,im4 quad gif \ + >>> outbands="band( (i1//i2), (i3//i4) )" + +Do the same example but create a border of 2 gray pixels around each +of the images and apply the AIPS0 LUT with brightness/contrast values +to create a color image: + + cl> copy /usr/local/lib/imtoolcmap/aips0.lut . + cl> type expr.dat + setcmap ( + band( + 128, 128, + (repl (128,2) // i1// repl (128,2) // i2 // repl (128,2)), + 128, 128, + (repl (128,2) // i3// repl (128,2) // i4 // repl (128,2)), + 128, 128 ), + "aips0.lut", + 0.54, + 1.03) + cl> export im1,im2,im3,im4 cquad gif outbands="@expr.dat" + +.fi + +Automatically scale an image ignoring data in a bad pixel mask (bpm), map the +result to the greyscale part of the "overlay" color map, and apply a +overlay pattern given by another mask (pattern). + + cl> export dev$pix,bpm,pattern foo gif \ + >>> outbands = "setcmap(i3==0?(zscalem(i1,i2==0)*200/255.):i3+203,'overlay')" + + +The pattern has values of 1 and 203 is added to get it into the color map +values of the overlay colors. The factor of 200/255 is to scale the result +of zscalem from the range 0-255 to the range 0-200. + +.ih +NOTES + This task is new with V2.11. + + (long int headers in RAS and XWD may cause problems on 64-bit +machines like the Alpha where host software expects 64-bit values. Need to +see if IRAF on the alpha produces 32 or 64-bit longs, either way exchanging +images may be a problem) + +.ih +BUGS + Output of bitmap images is currently not supported. +.ih +SEE ALSO +import, tvmark, imexpr +.endhelp diff --git a/pkg/dataio/doc/import.hlp b/pkg/dataio/doc/import.hlp new file mode 100644 index 00000000..da8047b7 --- /dev/null +++ b/pkg/dataio/doc/import.hlp @@ -0,0 +1,631 @@ +.help import Oct94 dataio +.ih +NAME +import -- create an IRAF image from an arbitrary binary file +.ih +USAGE +import binfiles images +.ih +PARAMETERS +.ls binfiles +The list of input binary files to be read. +.le +.ls images +The list of output IRAF images to be written. This parameter only needs to +be specified when generating an output image (see the \fIoutput\fR parameter +description). +.le +.ls format = "sense" +The type of format to be processed. In default mode, i.e. \fIsense\fR, +the format database is searched for a format identifier that evaluates +truly for the current binary file, the input file parameters are then +derived from the database entry. A specific format name in the database may +alternatively be given in which case the input params are derived from that +entry in the database. If \fIformat\fR=\fInone\fR the task parameters +are used to describe the input file. +.le + +.ce +INPUT PARAMETERS +.ls dims = "" +The input file dimension string. This is a space or comma delimited string +containing the length of the file in each dimension, e.g. "512,512,3". +.le +.ls pixtype = "" +Input pixel type. This is a comma delimited string giving the type and size +of each pixel, and an optional tag name to be used in the \fIoutbands\fR +expressions. The syntax for the pixtype entry is +.ls [:tag],[:tag],[....] + +where +.nf + type = b # byte (no conversions) + u # unsigned integer + i # signed integer + r # ieee floating point + n # native floating point + x # ignore (skip) + + nbytes = 1, 2, 4, or 8 + + tag is something like 'r','g','b' (color triplets), 'r', + 'i' (complex data), etc. If no tags are given one will + automatically be assigned of the form 'b1', 'b2', etc. + +.fi +.le +.le +.ls interleave = 0 +Pixel interleave type. If the \fIpixtype\fR parameter is a composite then +the input pixel are pixel-interleaved (i.e. each pixel in a band is stored +together, as with RGB triplets) and this parameter is ignored. If +the \fIpixtype\fR is an atomic value and \fIinterleave\fR is a positive +number the image is line interleaved (e.g. a line of 'R', followed by a +line of 'G', and so on). If the \fIpixtype\fR is atomic and \fIinterleave\fR +is zero, the no data interleaving is assumed and each band in the file +is stored sequentially. +.le +.ls bswap = "no" +Type of byte-swapping to perform. By default no byte swapping is done, +if \fIbswap\fR is "yes" then all input values are byte swapped, if \fIbswap\fR +is "i2" then only short integers are byte swapped, if \fIbswap\fR is "i4" then +only long integers are swapped. A combination of "i2,i4" can be used to +swap only integer values, floating point numbers will not be swapped. +.le +.ls hskip = 0 +Number of bytes preceding pixel data to skip. +.le +.ls tskip = 0 +Number of bytes to skip at end of file. +.le +.ls bskip = 0 +Number of bytes between image bands to skip. +.le +.ls lskip = 0 +Number of bytes to skip at font of each line. +.le +.ls lpad = 0 +Number of bytes to skip at end of each line. +.le + +.ce +OUTPUT PARAMETERS +.ls output = "image" +Type of output to generate. Possible values include "none" process the files +but not generate an output image (e.g. to check the parameter values for +correctness), "image" to generate an output image, "list" to generate a +pixel listing of the file as would be produced by the \fILISTPIX\fR task +on the image if were converted (no image is created with this option), +or "info" to print information about the file. The \fIimages\fR parameter +is only used for \fIoutput\fR=image. +.le +.ls outtype = "" +The data type of the output image. May be one of 's' for a short image, 'i' +for an integer image, 'l' for a long image, 'r' for a real image, and 'd' +for a double precision image. If no \fIouttype\fR is specified then the +datatype of the \fIoutbands\fR expression is used. This parameter is only +used when \fIoutput\fR is set to "image". +.le +.ls outbands = "" +Output image band expressions. If no expressions are given then all of the +input pixels will be converted. The number of output bands may be more or +less than the number of input bands. See the \fIOUTBANDS EXPRESSIONS\fR +section for a more complete description of this parameter. +.le +.ls imheader = "" +Image or header keyword data file. If an image is given then the image header +is copied. If a file is given then the FITS format cards are copied. +This only applies to new images. The data file consists of lines +in FITS format with leading whitespace ignored. A FITS card must begin +with an uppercase/numeric keyword. Lines not beginning with a FITS +keyword such as comments or lower case are ignored. The user keyword +output of \fBimheader\fR is an acceptable data file. See \fBmkheader\fR +for further information. +.le + +.ls database = "imcnv$lib/images.dat" +The format database. This may also be a list of files to be searched (e.g. +so that user-defined databases may be included), which will be treated as +a single database. +.le +.ls verbose = yes +Print verbose output during the conversion? +.le +.ls buffer_size = 64 +Number of image lines \fIper band\fR to buffer in memory before writing to +disk. Image buffering can increase task performance by as much as a factor +of 30 for some formats but requires more memory. +.le + +.ih +DESCRIPTION + + The \fIimport\fR task is used to convert arbitrary raster binary +files to IRAF format images. The input format may be specified either +through the task parameters (\fIformat\fR set to 'none'), or as an entry +in a database of known formats (\fIformat\fR set to the name of the entry). +If the format of the image is not known a priori, the database can be +searched and each record will be evaluated for an expression which +identifies the format (\fIformat\fR set to "sense"). The task will +output either an IRAF image, a list of pixel values +in a manner similar to the \fILISTPIX\fR task, or information about the +file format if it is supported in the database. + +.ih +Input File Specification + The input raster is assumed to be at most three dimensional, with +pixels of various sizes that can be interleaved in a variety of ways. +No compression schemes are yet supported, except in the case of builtin +formats where special code has been written to handle to format. +Byte-swapping and floating point conversion of pixels (from IEEE to +native) is also supported. + + The \fIpixtype\fR and \fIinterleave\fR parameters define the pixel +storage in the binary file. \fIPixtype\fR is a comma delimited string, +the elements of which define the type and size of each pixel. An optional +'tag' name may be given to each pixel for use in the \fIoutbands\fR +expressions. If no tag is given one will automatically be assigned. +For composite pixtypes (i.e. when more than one element is listed), the +data are assumed to be pixel interleaved (e.g. stored as { {RGB}, {RGB} ...} +triplets). For atomic (i.e. single) pixtypes, a positive value of +\fIinterleave\fR indicates that the data are stored in a line-interleaved +manner (e.g. a line of R, a line of G, ...). If \fIinterleave\fR is +zero and \fIpixtype\fR is atomic, then no interleaving is done and the +image bands are thought to be stored sequentially. Minimal error +checking is done to make sure the +combination of these parameters is correct. + + The file may contain arbitrary padding around the pixels as +defined by the \fItskip\fR, \fIbskip\fR, \fIlskip\fR, and \fIlpad\fR +parameters, header information may be skipped by setting the \fIhskip\fR +parameter. Additionally, pixels may be ignored on input while still +specifying the full format. +.ih +Output Parameters + Once a format has been found, the task may output an IRAF image +by setting \fIoutput\fR to "image", a list of the pixels in the file +can be written to STDOUT by setting \fIoutput\fR to "list", or information +about the input file can be printed by setting \fIoutput\fR to "info". +If \fIoutput\fR is set to "none" then no output will be generated, this +can be used to check for read errors on the input file to verify task +parameters. The datatype of the output image can be set by specifying +the \fIouttype\fR parameter. + + The \fIoutbands\fR parameter is a list of expressions which are +evaluated to compute the pixels in each band of the output image. Operands +in these expressions consist of numeric constants and the pixtype tags +(either user-supplied tags or the automatic tags), general arithmetic +expressions are supported, which can include any of the special functions +listed below. The simplest expression is the name of a tag itself. +Regardless of the storage of pixels in the input file, each image band is +separated on output unless an expression is given which combines them. +See below for more details on \fIoutbands\fR. + + Header information may be added to an output image by naming +either a keyword file or an existing image header listing in the +\fIimheader\fR parameter. A header keyword data file consists of lines +of FITS format cards. Leading whitespace is ignored. Lines not recognized +as FITS cards are ignored. A valid FITS card is defined as beginning with +a keyword of up to 8 uppercase, digit, hyphen, or underscore characters. If +less than 8 characters the remaining characters are blanks. The +ninth character may be an equal sign but must be immediately followed +by a blank. Such value cards should be in FITS format though no +attempt is made to enforce this. Any other ninth character is also +acceptable and the line will be treated as a comment. Note that this +way of recognizing FITS parameters excludes the case of comments +in which the first 8 characters are blank. The reason for allowing +leading whitespace and eliminating the blank keyword case is so that +the long output of \fBimheader\fR may be used directly as input. + +.ih +OUTBANDS EXPRESSIONS + + The outbands parameter is a comma delimited list of expressions, the +simplest of which is the name of a tag itself (or the default names of the +tags if none are provided in the \fIpixtype\fR param). +The input pixels, regardless of how they are stored in the binary file, +are always stored as separate bands in the output IRAF image. +The outbands expressions will be evaluated to compute the pixels in each +band of the output image. This means that e.g. RGB triplets in an input +file will be separated into different bands in the output image, unless a +single expression is given that combines them. The components named +in \fIpixtype\fR may be eliminated or re-ordered in \fIoutbands\fR to +exclude certain input bands, or to change the channel order. For example +the commands: + +.nf +cl> import file img pixtype="u1:a,u1:r,u1:g,u1:b" outbands="g,r,a" +cl> import file img pixtype="u1,u1,u1,u1" outbands="b3,b2,b1" +.fi + +both convert an input 32-bit image with ARGB components. In the first case +the output image is an IRAF image where the B component has been eliminated +and the channel order reversed. The second case is the same as the first but +uses the automatic tag names. A combination of user-supplied tags and +defaults could also be used. + + General interpreted arithmetic expressions are supported and can +contain any of the standard expression evaluator functions (see +the \fIimexpr\fR help page for more details). Special functions in +expressions also include: +.nf + + flipx (arg) - flip image in X + flipy (arg) - flip image in Y + gr[ea]y (r,g,b) - RGB to grayscale using the NTSC Y formula + red (arg) - get the red component of a colormap image + green (arg) - get the green component of a colormap image + blue (arg) - get the blue component of a colormap image + gamma (arg, gamma) - apply a gamma correction to the image + +.fi +The two flip functions can change the image orientation by reversing the order +of pixels within a line (a flipx() call), or it can flip an image from top- +to-bottom (a flipy() call). The flipping will apply to all bands of the out- +put image even if it was only used in one expression. To reverse the channel +order simply change the order of the tags in the outbands parameter. RGB +images may be converted to a single grayscale image using the NTSC formula: +.nf + + gray = (0.289 * r) + (0.587 * G) + (0.114 * B) + +.fi +Note that a similar grayscale conversion can be done by explicitly defining +a similar equation in \fIoutbands\fR and supplying different coefficients. + + The \fIred()\fR, \fIgreen()\fR, or \fIblue()\fR functions can be used +to get a single color component from a colormap image rather than the +grayscale equivalent of the colormap. For example, to separate an 8-bit +GIF color image into it's RGB components one could specify an outbands +parameter such as +.nf + +cl> import foo.gif bar format=gif outbands="red(b1),green(b1),blue(b1)" + +.fi + + Functions may also be nested in complex expressions such as: + +.nf + flipy (gray(r,g,b)) - convert to grayscale, flip in Y + flipx (flipy (gray (r,g,b))) - convert to grayscale, flip in X & Y + gray (r,g,255) - use constant 255 as the B band + gray (r,g+100,-b) - add constant to G, negate B +.fi + +.ih +FORMAT DATABASE + + The format database is a text file named as a task parameter. +Each record of a database entry is of the form: + +.nf + : + : + keyword = + keyword = + ...and so on +.fi + +A database record begins with the format name at the beginning of a line. +Whitespace at the beginning of a line is considered the continuation of a +previous line. Comments may be inserted in the database using the normal '#' +character, the remainder of the line is considered a comment. Blank lines +and comments are ignored, a record ends at the next line with a format name +at the beginning of the line. The task \fIdatabase\fR parameter +defines the text files to be +scanned as the database. If the parameter is a list of files then each file +in the list will be concatenated to a single database file used by the task. + + The format_name field is a string identifying each entry in the +database, any number of aliases may also be given to identify the same +format possibly known by another name. Supported keywords include: + +.nf + image_id - A boolean expression identifying the image type + id_string - Verbose name of file format + bswap - is file byte-swapped? (See Below) + dims - a whitespace/comma delimited string of dimensions + pixtype - pixel type, size [and tag], may be a composite + interleave - describes how pixels are stored + hskip - # of bytes of header info to skip + tskip - # of bytes of trailing info to skip at end of file + bskip - # of bytes of info to skip between image bands + lskip - # of bytes of info to skip at front of each line + lpad - # of bytes of info to skip at end of each line + error - A condition that would cause a file read error, + returns a string with the error message, otherwise + returns the string "okay" +.fi + +The 'image_id' string is an expression to be evaluated which, if true, +uniquely identifies the file format (such as a comparison to a "magic number"). +The 'id_string' is a verbose name of the format. +The 'error' keywords use the "? :" conditional syntax to +define a boolean expression which, when true, returns an error message and is +used to indicate a condition in a format which isn't supported. The remaining +keywords have the same meaning as the task parameters. Keywords not present +in the database record will take the default parameter value. + + Expressions consist of any valid string that may be evaluated with the +standard system expression evaluator evvexpr(). (See the documentation for this +procedure or the \fIIMEXPR\fR task help page for details of builtin functions +and operators.) Operators within expressions may be boolean, arithmetic, +or the string operators '?=' (substring equality) and '//' (concatenation). +Operands may be the special functions named below, previously defined +keywords, constants (numeric or strings), and the special operands + +.ls $FSIZE +The size of the binary file in bytes. In expressions this operand has an +integer datatype. For formats with variable header sizes this can be used +to determine the size of the header, since the size of the data can be +derived from the image dimensions and subtracted from the total size of the +file. +.le +.ls $FNAME +The name of the binary file. In expressions this operand has a character +datatype. As a last resort for images without any identifying features the +file name may possibly be used to determine the format from a file name +extension. +.le + + +.ih +Special Functions: + + In addition to the intrinsic functions already provided there are a +number of input and utility functions for the database. These are: +.nf + + \fIINPUT FUNCTIONS\fR + + ctocc ([offset]) - convert byte to printable char constant + ctod ([offset]) - convert string to double precision real + ctoi ([offset]) - convert string to integer + ctol ([offset]) - convert string to long + ctor ([offset]) - convert string to single precision real + ctowrd ([offset]) - get 1st white-space delimited word from str + + getstr ([offset,] len) - get a string at offset + getb ([offset]) - get a byte at offset + getu ([offset]) - get an unsigned short int at offset +geti[24] ([offset]) - get a signed int at offset +getr[48] ([offset]) - get an IEEE fp number at offset +getn[48] ([offset]) - get a native fp number at offset + + locate ([offset,] pat) - find an offset to a pattern + line (n) - offset of line N + + \fIUTILITY FUNCTIONS\fR + + skip (nbytes) - move offset by N-bytes + bswap (arg) - byte swap the argument + substr (str, c1, c2) - extract a substring from argument + stridx (test, str) - get 1st occurrence of 'test' w/in 'str' + +parameter (param) - return the current task parameter + default (param) - return the default task parameter + lsb_host () - returns true if host is little-endian + msb_host () - returns true if host is big-endian +.fi + +.ls ctocc ([offset]) [string] +Convert byte at the given offset to printable char constant. +If no offset argument is given the current offset is used. +.le +.ls ctod ([offset]) [double] +Convert string to double precision real. +The function reads a string from +the file and converts it up to the first unrecognized character. +If no offset argument is given the current offset is used. +.le +.ls ctoi ([offset]) [int] +Convert string to integer. +The function reads a string from +the file and converts it up to the first unrecognized character. +If no offset argument is given the current offset is used. +.le +.ls ctol ([offset]) [long] +Convert string to long. +The function reads a string from +the file and converts it up to the first unrecognized character. +If no offset argument is given the current offset is used. +.le +.ls ctor ([offset]) [real] +Convert string to single precision real. +The function reads a string from +the file and converts it up to the first unrecognized character. +If no offset argument is given the current offset is used. +.le +.ls ctowrd ([offset]) [string] +Get 1st white-space delimited word from str, leading whitespace is skipped. +If no offset argument is given the current offset is used. +.le +.ls getstr ([offset,] len) [string] +Get a string at offset. +If no offset argument is given the current offset is used, the length of +the string must be specified. +.le +.ls getb ([offset]) [int] +Get a byte at offset. +If no offset argument is given the current offset is used. +.le +.ls getu ([offset]) [int] +Get an unsigned short integer at offset. +If no offset argument is given the current offset is used. +.le +.ls geti[24] ([offset]) [int] +Get a signed int at offset. +If no offset argument is given the current offset is used. +Long integers values can be read by specifying the function as geti4(), +the names geti() and geti2() return short integers. +.le +.ls getr[48] ([offset]) [real/double] +Get an IEEE floating point number at an optional offset. +If no offset argument is given the current offset is used. +Double precision values can be read by specifying the function as getr8(), +the names getr() and getr4() return single precision real. +.le +.ls getn[48] ([offset]) [real/double] +Get a native floating point number at an optional offset. +If no offset argument is given the current offset is used. +Double precision values can be read by specifying the function as getn8(), +the names getn() and getn4() return single precision real. +.le +.ls locate ([offset,] pat) [int] +Compute an offset. +If no offset argument is given the current offset is used. +.le +.ls line (N) [int] +Offset of line N in bytes. The database is rewound and the offset of the +requested line number is returned, line are delimited by the '\n' character. +.le +.ls skip (nbytes) [int] +Move current offset by N-bytes. The number of bytes skipped is returned as +the function value. +.le +.ls bswap (arg) [type of arg] +Byte swap the argument. +.le +.ls substr (str, first, last) [string] +Extracts a substring from string \fIstr\fR. The first character in +the string is at index 1. +.le +.ls stridx (test, str) [int] +Finds the position of the first occurrence of any character found +in \fItest\fR in the string \fIstr\fR, returning 0 if the match fails. +.le +.ls parameter (param) [param type] +Return the current task parameter. The parameter is specified as a string +containing the name of a task parameter, the type of the returned value is +the parameter type +.le +.ls default (param) [param type] +Return the default task parameter. The parameter is specified as a string +containing the name of a task parameter, the type of the returned value is +the parameter type +.le +.ls lsb_host () [bool] +Returns true if host is little-endian. +This function can be used as the \fIbswap\fR keyword expression for formats +with a specified byte order. +.le +.ls msb_host () [bool] +Returns true if host is big-endian. +This function can be used as the \fIbswap\fR keyword expression for formats +with a specified byte order. +.le + +.ih +BYTE SWAPPING + + The 'bswap' database entry is similar to the task parameter, it may +be used to set byte swapping for the whole file, or for only certain data +types. The value is a string parameter that may be "yes" to byteswap the +whole file, "no" to not swap anything, or a comma delimited string of types +described below to enable swapping for only those values. +.nf + + bswap = { no | yes | i2 i4 } + + no # no swapping (default) + yes # byte swap whole file + i2 # byte swap short ints only + i4 # byte swap long ints only +.fi + + The \fIbswap\fR task parameter applies only to the pixel data, +but the bswap keyword in a database record sets byte-swapping +for the header information: arguments to the input and conversion functions +will be byteswapped prior to being evaluated by the function. The bswap() +special function can be used to negate byteswapping for a particular +argument if it is or is not set by the keyword (the default is no byte +swapping). + +.ih +EXAMPLES +.nf + +Get a list of known input formats: + + cl> import "" "" output=info + +Get a list of known input formats, including those defined by the user: + + cl> import "" "" output=info database="dev$images.dat,mydb.dat" + +Get a list of the file formats of each image in the directory: + + cl> import file* "" format="sense" output=info verbose- + file1.ras Sun rasterfile + file1.eps unknown format + file1.pgm 8-bit PGM file + : : + +Get a list of the file formats of each image in the directory and +print out some information about each file: + + cl> import file* "" format="sense" output=info verbose+ + file1.ras: Sun Rasterfile + Resolution: 320 x 200 + Pixel type: 8-bit unsigned integer + Pixel storage: non-interleaved + Header length: 137 bytes + Byte swapped: no + ... : + +Read a raw 8-bit file of pixels into an unsigned short IRAF image: + + cl> import file img format="none" dims="512,512" pixtype="b1" \ + >>> outtype="u" outbands="b1" + +Read a JPL VICAR image or 8-bit Sun rasterfile: + + cl> import file img format="vicar" + cl> import file img format="sunras" + +Concatenate three separate red, blue, and green images and convert + to a single grayscale image: + + cl> concat pic.[rgb] > rgb + cl> import rgb img format=none dims="640,480,3" \ + >>> pixtype="u1" interleave=0 outbands="gray(b1,b2,b3)" + +Read an 8-bit colormap GIF image and separate the RGB colors into + separate bands in the output image: + + cl> import file.gif img outbands="red(b1),green(b1),blue(b1)" + +Read three 8-bit rasterfiles with 200 byte-headers as if they were + a single image, and combine the images to a single output band: + + cl> concat pix.* > rfiles + cl> import rfiles img dims="512,512,3" pixtype="b1" \ + >>> hskip=200 bskip=200 interleave=0 outbands="gray(b1,b2,b3)" + +Read a FITS image with one header record in which the data bytes + are incorrectly swapped, but the header info is in the right order: + + cl> rfits nite1.fits "" nite1 + File: nite1 1866-A Size = 640x480 + cl> imheader nite1 l+ > imheader.dat # Save the header info + cl> imdel nite1.imh + cl> import nite1.fits nite1 format="none" dims="640,480" \ + >>> bswap+ hskip=2880 pixtype="i2" outtype="s" imheader="imheader.dat" + +.fi + +.ih +BUGS +Bitmap images are not yet supported. Their most logical use would be as +pixel masks but there hasn't been much call for these formats so they may +be implemented at a later time. +.ih +REVISIONS +.ls IMPORT V2.11 +This is a new task in this version. +.le +.ih +SEE ALSO +export. imexpr, hedit, default image database imcnv$lib/images.dat +.endhelp diff --git a/pkg/dataio/doc/mtexamine.hlp b/pkg/dataio/doc/mtexamine.hlp new file mode 100644 index 00000000..15504254 --- /dev/null +++ b/pkg/dataio/doc/mtexamine.hlp @@ -0,0 +1,84 @@ +.help mtexamine Apr84 dataio +.ih +NAME +mtexamine -- examine the structure of magtape or a single disk file +.ih +USAGE +mtexamine tape_file +.ih +PARAMETERS +.ls tape_file +Tape or disk file, e.g. "mta1600[2]", "mta1600" or "data". +.le +.ls file_list = "1-999" +List of tape file numbers or ranges delimited by commas, e.g. "1-3,5-8". +File_list is used only if no file number is given in tape_file. +Files will be read in ascending order, regardless of the order of the list. +Reading will terminate if EOT is reached, thus a list such as "1-999" +may be used to read all the files on the tape. File_list is ignored is input +is a single disk file. +.le +.ls dump_records = no +Dump selected records? +.le +.ls rec_list = "1-999" +List of tape record numbers or ranges to be dumped delimited by whitespace +or commas e.g "1-3,4". +.le +.ls swapbytes = no +Swap bytes? +.le +.ls byte_chunk = 1 +The number of bytes which are considered as one output element. +The maximum number of bytes permitted in byte_chunk is the number of +bytes in a long integer on the host machine. +.le +.ls output_format = "o" +Permitted types are character(c), octal(o), hexadecimal (x), decimal (d) +or unsigned decimal (u). Character dumps are only permitted for byte_chunk = 1. +Unless decimal format is specified, the data are dumped as +unsigned integers. +.le +.ih +DESCRIPTION +By default mtexamine determines the record structure of all files +on a magnetic tape or a single disk file. +Selected files can be dumped by setting the file_list parameter. +Selected records can be dumped by setting the dump_record switch +and entering a record list. The user can select the byte chunk +and the output format for the dump. + +Mtexamine can also be used to dump a single disk file. However the concept +of a block is not well defined for disk files. Mtexamine defines a block +to be one IRAF file io block which is usually some multiple of the machine +block size. +.ih +EXAMPLES +1. Determine the record structure of a magnetic tape and send the result to +the file tapedump. + +.nf + cl> mtexamine mtb1600 > tapedump +.fi + +2. Dump the third tape file in octal bytes on the standard output. + +.nf + cl> mtexamine mtb1600[3] du+ +.fi + +3. Dump the contents of the fifth record of the third tape file in ASCII +characters on the standard output. + +.nf + cl> mtexamine mtb1600[3] du+ re=5 ou=c +.fi +.ih +BUGS +The IRAF magtape i/o routines do not permit data beyond a double EOF +to be accessed. Therefore mtexamine cannot be used to examine tapes with +embedded double EOFs. +.ih +SEE ALSO +rewind, allocate +.endhelp diff --git a/pkg/dataio/doc/rcardimage.hlp b/pkg/dataio/doc/rcardimage.hlp new file mode 100644 index 00000000..910cfc72 --- /dev/null +++ b/pkg/dataio/doc/rcardimage.hlp @@ -0,0 +1,120 @@ +.help rcardimage Jan87 dataio +.ih +NAME +rcardimage -- Convert a card image file into an IRAF text file +.ih +USAGE +rcardimage cardfile file_list textfile +.ih +PARAMETERS +.ls cardfile +The cardimage source file. Cardfile may be either a template specifying a +list of disk files, e.g. card* or a mag tape file specification of the +form mtl*[n], where mt stands for mag tape, l stands for a specific drive, +* stands for the density and [n] is the tape file number. If no tape file +number is specified then the tape file numbers are taken from the +file_list parameter. +.le +.ls file_list +A list of tape file +numbers or ranges delimited by commas, for example +"1,3,5-8", which is used only if the magtape device is specified. +Files will be read in ascending order, regardless of +the ordering of the list. Reading will terminate silently if EOT +is reached, thus a list such as "1-999" may be used to read all +files on a tape. +.le +.ls textfile +Name of the output file. If multiple input files, multiple output +files will be generated by concatenating the tape file number or +disk sequence number onto the textfile string. +.le +.ls card_length = 80 +The number of columns per card in the input card image file. +Must be divisible by the number of bytes per "IRAF character" (2 on most +machines). The task reblock can be used to pad files with odd-sized +cards. +.le +.ls max_line_length = 161 +The maximum line length to be generated. Default is maximum size +of a line permitted by IRAF. +Useful for stripping columns 73-80 from Fortran card image files. +.le +.ls entab = yes +Replace blanks with tabs and blanks. Tabsize is 8. +.le +.ls join = no +Rejoin oversize lines. +.le +.ls contn_string = ">>" +Marker to enable program to recognize oversize lines. +.le +.ls trim = yes +Trim trailing whitespace from each line. +.le +.ls verbose = yes +Output messages listing files created, number of cards +processed, etc. +.le +.ls ebcdic = no +Translate from ebcdic to ascii. +.le +.ls ibm = no +Translate from ibm ebcdic to ascii. +.le +.ls offset = 0 +Integer parameter specifying the tape file number offset. For example if +offset = 100, card_file = "card" and file_list = "1-3", the output file +names will be "card101", "card102" and "card103" respectively, instead of +"card001", "card002" and "card003". +.le + +.ih +DESCRIPTION +Multiple cardimage files are read from disk or tape. +If only the magtape device is specified, +a list of file numbers is requested. In the latter case, output files +have the form root_filename // tape(disk)_file_number. By default, trailing +whitespace is trimmed from each line. + +.ih +EXAMPLES +1. Convert a set of ASCII cardimage files on magnetic tape to IRAF text files, +replacing blanks with tabs and blanks, and trimming whitespace from +the ends of lines. + + cl> rcardimage mtb1600 1-999 textfiles + +2. Convert a set of ASCII cardimage files on disk to IRAF test files. + + cl> rcard card* 1 textfiles + +3. Convert a set of EBCDIC cardimage files on magnetic tape to IRAF text files, +trimming whitespace from the ends of lines but leaving embedded blanks +unchanged. + + cl> rcardimage mtb1600 1-999 textfile en- ebc+ + +4. Convert an odd-blocked (81 bytes per card) rcardimage file on tape to an +IRAF text file by using reblock to write the file to disk and pad the cards +with blanks, followed by rcardimage to convert the file to an IRAF textfile. + + cl> reblock mta[1] cardimage inrecord=81 outrecord=82 \ + padchar=" " + + cl> rcardimage cardimage 1 textfile card_length=82 + +.ih +BUGS +Due to portability considerations The card length in bytes must fill an +integral number of IRAF characters. On most machines this means that the +length of the card must be an even number of bytes . The task should be +generalized to require only that the tape record length be specified +to read odd blocked card image files. + +The size of the output text file lines is currently restricted to 161 +or fewer characters. +.ih +SEE ALSO +wcardimage +.endhelp diff --git a/pkg/dataio/doc/reblock.hlp b/pkg/dataio/doc/reblock.hlp new file mode 100644 index 00000000..dd3a506a --- /dev/null +++ b/pkg/dataio/doc/reblock.hlp @@ -0,0 +1,177 @@ +.help reblock Jan93 dataio +.ih +NAME +reblock -- copy a file to tape or disk with optional reblocking +.ih +USAGE +reblock infiles outfiles file_list +.ih +PARAMETERS +.ls infiles +The input file list or device name, e.g. "mta1600[2]" or "mta800", "file1", +"file1,file2", or "@infiles". +.le +.ls outfiles +The list of output files or device name, e.g. "gemini!mtb", "out1", +"out1,out2", or "@outfiles". +If multiple file output to disk is requested, and the specified number +of output files is 1, the output file names will be generated +by concatenating the tape file number (the input files are on tape) or +a sequence number (the input files are on disk) onto the output file +name. +.le +.ls file_list +List of tape file numbers or ranges delimited by commas, +e.g. "1-3,5_8". +File_list is requested only if the magtape input device is specified. +Files will be read in ascending order regardless of the ordering of the list. +Reading will terminate silently if EOT is reached, thus a list such as +"1-999" may be used to read all files on the tape. +.le +.ls newtape +If the output device is magtape, newtape specifies whether the tape is +blank or contains data. +Newtape is requested only if no tape file number is specified, e.g. "mta1600". +.le +.ls outblock = INDEF +Size of the output block bytes. +In the default case and for disk output, the output block size is set to the +file i/o disk default buffer size. +.le +.ls inrecord = INDEF, outrecord = INDEF +The sizes of the input and output logical records in bytes. +The default input and output record sizes are set equal to +the input and output block sizes respectively. If inrecord > outrecord, +records are trimmed; if inrecord < outrecord, records are padded; if +inrecord = outrecord, records are simply counted. If only one of inrecord or +outrecord is set, the undefined parameter defaults to the value of the +other. +.le +.ls skipn = 0 +The number of input blocks (tape input) or records (disk input, size inrecord) +to be skipped. +.le +.ls copyn = INDEF +The number of input blocks (tape input) or records +(disk input, size inrecord) to be copied. Copyn defaults to a very large number. +.le +.ls byteswap = no +Swap every other byte. For example if byteswap is enabled, bytes 1 2 3 4 5 6 +would become bytes 2 1 4 3 6 5 on output. +.le +.ls wordswap = no +Swap every 4 bytes. For example if byteswap is enabled, bytes 1 2 3 4 5 6 7 8 +would become 4 3 2 1 8 7 6 5 on output. +.le +.ls pad_block = no +If pad_block is set, reblock pads trailing blocks until they are outblock +bytes long, otherwise trailing blocks may be short. +.le +.ls padchar = 0 +Single character used to pad blocks or records. +Padchar is only requested if pad_record or pad_block +is set. If padchar equals one of the digits 0 through nine, records and +blocks are padded with the face value of the character, otherwise the +ASCII value is used. +.le +.ls offset = 0 +The number which added to the tape file number is appended to \fIoutfiles\fR +to produce the output file name. For example if file_list = "1-3", outfiles = +"out" and offset = 100, the three files out101, out102, out103 would +be produced rather than out001, out002 and out003. +.le +.ls verbose = yes +Print messages about files, blocks copied etc. +.le +.ih +DESCRIPTION +REBLOCK is a procedure to copy disk or tape resident files to +disk or tape. Multiple input tape or disk files may be specified. +If multiple files are output to disk, and only one output file name is +specified, the output file names will be +generated by concatenating the tape file number (the input files are on tape) +or a sequence number (the input files are on disk) onto the output file name. +The user may request magnetic tape output to begin at a specific file on +tape, e.g. mta1600[5] in which case file five will be overwritten if it +exists, or at BOT or EOT. If no file number is specified REBLOCK asks +whether the tape is new or old and begin writing at BOT or EOT as +appropriate. + +Before beginning the copy, the user may request reblock to skip +n (default 0) blocks (tape input) or logical records (disk input). +The user can also specify that +only n (default all) blocks (tape input) or records (disk input) +are to be copied. Before the copy the data may be optionally word-swapped +(default no) and/or byte-swapped (default no). If verbose is specified +(default yes) reblock prints the input and output file names, +the number of blocks read and written and the number of records read and +written. + +Reblock +uses the default buffer sizes supplied by mtio and file i/o to determine the +maximum number of bytes which can be read in a single read call. For tapes +this corresponds to the maximum number of bytes per block permitted by the +device. Mtio will not read more than one block per read call. Therefore the +actual number of bytes read will be less than or equal to the mtio buffer size. +For disk files the default buffer size set by IRAF is a multiple of the +disk block size. If the disk file is smaller than one block +or the last block is partially full, the number of bytes read +will be less than the default buffer size. All magtape and disk reads are +done with the file i/o read procedure and a call to fstati determines the number +of bytes actually read. + +If all the defaults are set, a binary copy is performed. +In tape to tape copies the block and record sizes are preserved, +but the density may +be changed by specifying the appropriate output file name e.g. mta800 or +mta1600. +Reblocking occurs in tape to disk transfers, if records, are trimmed, +padded or counted, or if blocks are padded. +If a disk to tape transfer is requested +the output block size will be the default file i/o buffer size. +The last block in a file may be short. If uniform sized blocks are +desired, pad_block must be set, in which case trailing partially filled +blocks will be padded with padchar. + +Logical records are distinguished from blocks (physical records). +The input and output record sizes default to +the size of the input and output blocks respectively. +Logical records may be shorter or longer than the block sizes. + +.ih +EXAMPLES +1. Copy a magnetic tape preserving the record sizes but changing +the density from 800 bpi to 1600 bpi. + +.nf + cl> reblock mtb800 mta1600[1] 1-999 +.fi + +2. Reblock a magnetic tape changing the block size from 4000 bytes to 8000 +bytes and padding the last block. + +.nf + cl> reblock mtb1600 mta1600[1] 1-999 outb=8000 padb+ +.fi + +3. Copy a series of disk fits files to tape + +.nf + cl> reblock @fitsfiles mta[1] outb=28800 +.fi + +4. Trim the records of a disk file. + +.nf + cl> reblock infile outfile inrec=80 outrec=72 +.fi + +5. Pad the records of a disk file with blanks. + +.nf + cl> reblock input output inrec=81 outrec=82 padchar=" " +.fi +.ih +SEE ALSO +t2d +.endhelp diff --git a/pkg/dataio/doc/rfits.hlp b/pkg/dataio/doc/rfits.hlp new file mode 100644 index 00000000..d28690c1 --- /dev/null +++ b/pkg/dataio/doc/rfits.hlp @@ -0,0 +1,228 @@ +.help rfits May97 dataio +.ih +NAME +rfits -- convert image data in FITS files to individual IRAF images +.ih +USAGE +rfits fits_file file_list iraf_file +.ih +PARAMETERS +.ls fits_file +The FITS data source. Fits_file is either a list of disk files or a tape +device specification of the form mt[*][n], where mt is the mag tape +device (e.g. mta), * is an optional density (e.g. 1600), and [n] is an +optional tape file number. If n is specified then only image data in the +nth tape file is read. +.le +.ls file_list +The list of FITS extensions to be read from each disk file or from a single +tape file, or the list of tape files AND FITS extensions to be read from +an entire tape. FITS extensions are numbered from 0 to n, tape files are +numbered from 1 to n. If file_list is "", only the 0th extension is read +from each disk file or from a single tape file, but all the files and +extensions are read from an entire tape. Legal file lists are composed +of a series of file numbers and / or file ranges separated by commas +or whitespace. For example the string + + "1-3,4-8" + +will convert ALL the FITS extensions in files 1 through 8 on tape, +but only FITS extensions 1 through 8 from a disk file or a single tape file. +For the case of disk input, the same FITS extensions must be read from +each input file. For the case of tape input the FITS extensions to be +read from each file must be specified separately. For example the following +string + + "1-10[2-4],15-21[1-10]" + +tells rfits to convert extensions 2 through 4 in tape files 1 through 10 +and extensions 1 through 10 in tape files 15 through 21. Rfits will only +convert extensions which contain image data. Other types of fits data +such as tables will not be converted. +.le +.ls iraf_file +The IRAF file which will receive the FITS image data if the make_image parameter +switch is set. Iraf_file may be a template of output image names or +a single root output image name. In the former case one output image name +must be specified for every input file. In the latter case iraf_file is +a root output image name to which the input file sequence number or tape +file number is appended if the number of input files > 1. For example +reading files 1 and 3 from a FITS tape with a value of iraf_file of "data" +will produce the files data0001 and data0003, whereas reading the same +two files with a value of iraf_file of "data1,data2" will produce the files +data1 and data2. Extension numbers will be appended to the root output +names if appropriate. +.le +.ls make_image = yes +If make_images is "yes" convert the FITS image data to IRAF image data, +otherwise simply print the header information using the long_header or +short_header switches. +.le +.ls long_header = no +If long_header is "yes" the full FITS header is printed on the standard output. +.le +.ls short_header = yes +If short_header is "yes" and long_header is "no", only the output filename, +the title string, and the image dimensions are printed on the standard output. +.le +.ls datatype +The output image data type. Datatype may be s (short integer), i (integer), +u (unsigned integer), l (long integer), r (real), or d (double). Data +truncation may occur if an inappropriate data type is specified. If an +unsupported data type or a null string is supplied then a default data +type is selected based on the value of the fits bitpix, bscale, and bzero +parameters. If the bscale and bzero parameters in the FITS header are +undefined or equal to 1.0 and 0.0 respectively, rfits selects datatype +s or l depending on bitpix. If bscale and bzero are set to 1.0 and 32768.0, +rfits selects datatype, otherwise rfits selects datatype r. +.le +.ls blank = 0. +The IRAF image value assigned to a FITS blank pixel. +.le +.ls scale = yes +If scale is "no" then the data values are read directly from the FITS image +without conversion. Otherwise rfits scales the data before output using +the values of bscale and bzero. +.le +.ls oldirafname = no +If the oldirafname switch is set rfits will attempt to restore the image to +disk with the filename defined by the IRAFNAME parameter in the FITS header. +.le +.ls offset = 0 +An integer parameter specifying the offset to the current tape file +number. For example if offset = 100, iraf_file = "fits" and file_list = "1-3" +then the output file names will be "fits0101", "fits0102" and "fits0103" +respectively rather than "fits0001", "fits0002" and "fits0003". +.le +.ih +DESCRIPTION +FITS data is read from the specified source; either disk or +magnetic tape. The FITS header may optionally be printed on the standard +output as either a full listing or a short description. +The FITS long blocks option is supported. + +At present non-standard FITS files (SIMPLE = F) and files containing +group data are skipped and a warning message is issued. +Image stored in the FITS standard extension IMAGE can be read. +Other standard extensions such as TABLE and BINTABLE are currently ignored. + +A warning message will be issued if the default user area allocated in +memory is too small +to hold all the FITS parameter cards being read in by RFITS. +Since the default user area is 64000 +characters and a single card image is 81 characters long, the normal +user area will hold ~800 complete card images. RFITS will not permit +partial cards to be written. The user can override the default user area +length by setting the environment variable min_lenuserarea (see example +below). +.ih +EXAMPLES +1. Convert all the image data on a mag tape to individual IRAF +images. Allow rfits to select the output datatype and set blanks +to zero. + +.nf + cl> rfits mtb1600 "" images + + or alternatively + + cl> rfits mtb1600 * images +.fi + +2. Convert FITS files on disk to IRAF images. In the first example case the +files specified by fits* are written to images images0001, images0002, etc. +In the second example the fits disk files listed one per line in the text +file fitslist are written to the output images listed one per line in +the file imlist. Note that by using 0 or "" for the file_list parameter +the user has told rfits to read only the primary fits data unit. + +.nf + cl> rfits fits* "" images + + or alternatively + + cl> rfits fits* 0 images + + + cl> rfits @fitslist "" @imlist + + or alternatively + + cl> rfits @fitslist 0 @imlist +.fi + +3. List the contents of a FITS tape on the standard output without creating +any image files. + +.nf + cl> rfits mtb1600 "" images ma- +.fi + +4. Convert FITS files on tape directly to IRAF images without scaling. + +.nf + cl> rfits mtb1600 "" images scal- +.fi + +5. Convert the first three FITS files on tape to IRAF image converting FITS +blank values to -1 in the process. Note that the user will not get what +he or she expects if the output data type is ushort. + +.nf + cl> rfits mta 1-3 images blank=-1 +.fi + +6. Read in a disk FITS file with a header roughly twice the usual IRAF length +of 64000 characters. + +.nf + cl> set min_lenuserarea = 128000 + cl> rfits fitsimage "" image +.fi + +7. Read a FITS tape which has 5 normal fits records (2880 bytes) to a tape +record. Notice that no hidden rfits parameters are required to do this. + +.nf + cl> rfits mta * images +.fi + +8. Convert only the zeroth FITS extension in each of the first 100 files on a +magnetic tape and try to restore the original IRAF image name in the process. + +.nf + cl> rfits mta 1-100[0] images old+ +.fi + +9. Convert the second, third, and fourth FITS extensions in the first 100 +files of a FITS tape and try to restore the original IRAF name in the process. + +.nf + cl> rfits mta "1-100[2-4]" images old+ +.fi + +10. Convert the second, third, and fourth FITS extensions in each of a list of +disk files and restore the original IRAF name in the process. + +.nf + cl> rfits @fitslist "2-4" images old+ +.fi + +11. Convert the second, third, and fourth FITS extensions in the fifth +mag tape file and try to restore the original IRAF name in the process. + +.nf + cl> rfits mta[5] "2-4" images old+ +.fi + +.ih +BUGS +Blank pixels are counted and set to a user determined value, but they are not +records in the output image header. + +Rfits can read image data only. Other FITS data types such as ASCII and +binary tables are skipped. +.ih +SEE ALSO +wfits, reblock, t2d, fits kernel +.endhelp diff --git a/pkg/dataio/doc/rtextimage.hlp b/pkg/dataio/doc/rtextimage.hlp new file mode 100644 index 00000000..f6b8f037 --- /dev/null +++ b/pkg/dataio/doc/rtextimage.hlp @@ -0,0 +1,84 @@ +.help rtextimage Oct93 dataio +.ih +NAME +rtextimage -- convert a text file to an IRAF image +.ih +USAGE +rtextimage input output +.ih +PARAMETERS +.ls input +A list of text files containing image pixels and optional header. Most likely +the output from \fIrcardimage\fR, see examples below. +.le +.ls output +The output IRAF image name. If more than one text file is being +read, the ordinal of the text file in \fBinput\fR +is appended to \fIoutput\fR to generate a unique image name. +.le +.ls otype = "" +The data type of the output IRAF image pixels. If left unset and the IRAFTYPE +keyword is found in the FITS header, output pixels will be of type IRAFTYPE. +If IRAFTYPE appears more than once in the FITS header, the last value of +IRAFTYPE is used. If left unset and the IRAFTYPE keyword is not provided in +the FITS header, the output data type is determined from the pixels themselves. +.le +.ls header = yes +If \fBheader\fR = yes, \fIrtextimage\fR will attempt to read a FITS +header at the beginning of each text file. +.le +.ls pixels = yes +Read the pixel values from the input text file. If no then the +output image is initialized to zero pixel values. +.le +.ls nskip = 0 +The number of lines to skip before reading pixels. This is used to +skip over a non-standard header and is important only when \fBheader\fR = no. +.le +.ls dim = "" +A string listing the dimension of each axis. The number of dimensions listed +equals the number of image dimensions. This information must be entered unless +it can be read from a FITS header. +.le +.ih +DESCRIPTION +Text files are converted to IRAF images files with procedure +\fBrtextimage\fR. The text file consists of an optional header optionally +followed by the pixel values. If no pixel values are read the image is +initialized to all zero pixel values. If pixel values a given they are +read in FITS order, that is, the leftmost subscript varies most rapidly. +The number of image dimensions and the length of each dimension must either +be read from a FITS header or supplied by the user. Internally, +\fBrtextimage\fR determines the format (integer or floating point) of the +pixels in the text file by reading the first one and assuming all others +are the same. +.ih +EXAMPLES +1. Read a file written by \fIwtextimage\fR from the magtape file "mta[1]" into +the IRAF image "picture". + + cl> rcard mta[1] | rtext out=picture + +2. Read a series of text files with no headers preceding the pixels. The +text files were previously read from tape with task \fBrcardimage\fR. +The two dimensional images are 512 by 320 pixels, and will be named +crab001, crab002, crab003, etc. + + cl> rtext text.* crab header- dim=512,320 + + +3. Read a file with a non-standard header. The header is 5 cardimages long. + + cl> rcard mta[5] | rtext out=spect.1 head- nskip=5 dim=1024 +.ih +TIME REQUIREMENTS +Task \fIrtextimage\fR requires about 145 cpu seconds to write a 512 square +image (integer or real) from a text file. +.ih +BUGS +The text file being read cannot have lines longer than SZ_LINE characters +(see hlib$iraf.h). +.ih +SEE ALSO +rcardimage, wtextimage +.endhelp diff --git a/pkg/dataio/doc/t2d.hlp b/pkg/dataio/doc/t2d.hlp new file mode 100644 index 00000000..5d36334c --- /dev/null +++ b/pkg/dataio/doc/t2d.hlp @@ -0,0 +1,70 @@ +.help t2d May89 dataio +.ih +NAME +t2d -- copy files from tape to disk quickly +.ih +USAGE +t2d input ofroot +.ih +PARAMETERS +.ls input +Tape file or device name, e.g. "mta1600[1]" or "mta" +.le +.ls files +List of tape file numbers or ranges delimited by commas, e.g. "1-3,5-8". +`Files' is requested only if no file number is given in `input'. +Files will be read in ascending order, regardless of the order of the list. +Reading will terminate if EOT is reached, thus a list such as "1-999" +may be used to read all the files on the tape. +.le +.ls ofroot +Root name to give output files. A three digit sequence number will be appended +to this root name for each file written if a file list is used. If the file +number is specifically given in the 'input' parameter, the output file will +be named this root without an appended sequence number. +.le +.ls verbose = yes +Flag to signal program that it should produce verbose output. This means +progress reports. +.le +.ls errignore = yes +Flag to signal program that tape records that give read errors should be +considered to have zero length. If set to 'no', error records are considered +to be the same length as all the other records on the tape. +.le +.ih +DESCRIPTION +T2d reads files from tape and puts them into disk files. No formatting is +performed so the bits and bytes are in the same order on disk as they were +on tape. The program uses double buffering and asynchronous i/o to speed +things up as much as possible. + +When read errors are encountered one of two things can happen. Depending +on the value of the parameter 'errignore', the error record is either +thrown out or considered valid data. If 'errignore' is 'no' when an error +is found, the input buffer is validated to the most recent 'good record' +length and written to disk. If 'errignore' is 'yes' when an error is +found, the input buffer is disposed of for that record. +.ih +EXAMPLES +1. To read the second image from mta at 1600 bpi, store the image into +"image" and see verbose output the command would be: + +.nf + cl> t2d mta1600[2] image +.fi + +2. To read all the files on mtb at the default speed of 1600 bpi and put +the disk files in root001, root002, root003, etc. and turn off verbose +output, the command would be: + +.nf + cl> t2d mtb root v- +.fi + +The program will prompt the user and ask for the list of files to be read +to which the response would be "1-999". +.ih +SEE ALSO +reblock +.endhelp diff --git a/pkg/dataio/doc/txtbin.hlp b/pkg/dataio/doc/txtbin.hlp new file mode 100644 index 00000000..c519125f --- /dev/null +++ b/pkg/dataio/doc/txtbin.hlp @@ -0,0 +1,28 @@ +.help txtbin Jun86 dataio +.ih +NAME +txtbin -- convert text files to binary files +.ih +USAGE +txtbin text_file binary_file +.ih +PARAMETERS +.ls text_file +Input file name or template, e.g. "abc" or "abc.*". +.le +.ls binary_file +Output file name. If multiple input files the file_number will be +added to the output file name. +.le +.ls verbose = "yes" +Print messages about files processed? +.le +.ih +EXAMPLES +1. Convert a text file on disk to a binary file on disk. + + cl> txtbin text_file binary_file +.ih +SEE ALSO +bintxt +.endhelp diff --git a/pkg/dataio/doc/wcardimage.hlp b/pkg/dataio/doc/wcardimage.hlp new file mode 100644 index 00000000..650f78ed --- /dev/null +++ b/pkg/dataio/doc/wcardimage.hlp @@ -0,0 +1,74 @@ +.help wcardimage Jun86 dataio +.ih +NAME +wcardimage -- convert IRAF text files to card image files +.ih +USAGE +wcardimage infiles outfiles +.ih +PARAMETERS +.ls textfile +A character string identifying the file (s) on disk to be processed. +The string acts as a "template" so that multiple files can be pro- +cessed. +.le +.ls cardfile +Name of the output tape device of the form "mta800" or "mta800[#]" +or name of disk file (s). EOT and BOT are acceptable tape file numbers. +The file number will be appended to +the output file name in the case of multiple file disk output. +.le +.ls new_tape +Specifies whether the output tape is blank or contains data. +.le +.ls contn_string = ">>" +Character string which will be inserted at the beginning of +card image lines which have been split from a single text line. +.le +.ls verbose = yes +Print messages of actions performed? +.le +.ls detab = yes +Remove tabs? +.le +.ls card_length = 80 +Number of columns per card. +.le +.ls cards_per_blk = 50 +Number of card images per physical record. +.le +.ls ebcdic = no +Translate ascii characters to ebcdic? +.le +.ls ibm = no +Translate ascii characters to ibm ebcdic? +.le +.ih +DESCRIPTION +If multiple file disk output is requested, ".crd" is appended to the input +file name. Oversize lines are split and prefixed by the string ">>". +.ih +EXAMPLES +1. Convert a set of IRAF text files to a set of blocked ASCII cardimage files +on tape, replacing tabs with blanks and prefixing the leftover portions +of oversize lines with ">>". + +.nf + + cl> wcardimage files* mtb1600[1] +.fi + +2. Convert a set of IRAF text files to a set of blocked EBCDIC cardimage files +on tape, replacing tabs with blanks and prefixing the leftover portions +of oversize lines with ">>". + + cl> wcardimage files* mtb1600[1] eb+ +.ih +BUGS +The card_length in bytes must be an integral number of chars. +At present WCARDIMAGE can only handle lines with less than or equal to +161 characters. +.ih +SEE ALSO +rcardimage +.endhelp diff --git a/pkg/dataio/doc/wfits.hlp b/pkg/dataio/doc/wfits.hlp new file mode 100644 index 00000000..67d6f3c3 --- /dev/null +++ b/pkg/dataio/doc/wfits.hlp @@ -0,0 +1,237 @@ +.help wfits May97 dataio +.ih +NAME +wfits -- convert individual IRAF image files to FITS image data +.ih +USAGE +wfits iraf_files fits_files +.ih +PARAMETERS +.ls iraf_files +The input IRAF image file(s), e.g. "image.imh" or "*.imh". +.le +.ls fits_files +The output FITS files. +Magnetic tape output is assumed if the first two characters of fits_files +are "mt", otherwise the disk output is assumed. Tape output will begin +at the file number specified in fits_files, e.g. file 5 if fits_files = +"mtb1600[5]", and the data in file 5 and succeeding files will be overwritten. +If no tape file number is specified in fits_files, the newtape parameter +is queried, and tape output will begin at BOT (beginning of tape) if +newtape = yes, otherwise at EOT (end of tape, after the double EOF). +Requesting a tape write at EOT on a blank tape may cause tape runaway. +In the case of disk output, fits_files may be either a file name template +or a root filename. In the former case there must be one output FITS file +name for every input image. In the latter case fits_files is a root name +and a sequence number will be appended to fits_files if the number of +input images > 1. +.le +.ls newtape +Boolean parameter specifying whether an output tape is blank or already +contains data. Newtape is requested only if no tape file number is specified in +fits_files, e.g. fits_files = "mtb1600". +.le +.ls bscale +The FITS bscale parameter, defined as p = i * bscale + bzero, where +p and i are the physical and tape data values respectively. +The bscale parameter is only requested if the scale switch is on +and the autoscale switch is off. +.le +.ls bzero +The FITS bzero parameter (see bscale for a definition). +Bzero is only requested if the scale switch is on and the autoscale +switch is off. +.le +.ls fextn = "fits" +The output fits file extension. If fextn is defined, an extension of +the form ".fextn", e.g. ".fits" is added to the output fits file name. +Fextn should be chosen to be compatible with one of the permitted fits +kernel extensions. +.le +.ls extensions = no +By default wfits writes each input image to a separate disk or tape FITS +file. If \fIextensions\fR is "yes", then wfits will write all the images in +the input image list to a single disk or tape FITS file using the FITS +standard IMAGE extension to write images other than the first. Extension +numbering is 0 indexed. The first image will be written to extension 1 if +\fIglobal_header\fR is "yes", or to extension 0 if \fIglobal_hdr\fR is "no". +.le +.ls global_hdr = yes +Write a short global header to the 0th extension of the output FITS file +if \fIextensions\fR is "yes". +.le +.ls make_image = yes +By default wfits writes the FITS image(s) to the output destination. +If the make_image switch is turned off, wfits prints the FITS headers +on the standard output and no output file is created. In this way the +output FITS headers can be examined before actually writing a FITS tape. +.le +.ls long_header = no +If this switch is set the full FITS header will be printed on the standard +output for each IRAF image converted. +.le +.ls short_header = yes +If this switch is set only a short header, listing the files processed and +their dimensions will be printed on the standard output. +The long_header switch must be turned off. +.le +.ls bitpix = 0 +A bitpix of 8, 16, or 32 will produce either an unsigned byte, +twos-complement 16 bit integer, or twos-complement 32 bit integer FITS +image. If bitpix is -32 or +-64 IEEE real or double precision floating point FITS images are produced. +If bitpix is set to 0 (the default), wfits will choose one of 8, +16, 32, -32 or -64 based on the data type of the IRAF image. +For example a short integer and real image will default to bitpix 16 and +-32 respectively. +Users should be wary or overriding the default value of bitpix as loss +of precision in their data may result. In this case wfits will issue a +warning message and an estimate of the maximum loss of precision to be +expected. +.le +.ls blocking_factor = 0 +The tape blocking factor for FITS. +Wfits normally writes \fIblocking_factor\fR * 2880 byte records, +where \fIblocking_factor\fR is an integer from 1 to 10. +If \fIblocking_factor\fR = 0, wfits uses the default FITS blocking +factor specified for the device by the "fb" parameter in the +file dev$tapecap, or 1 if the "fb" parameter is not present. For +devices which support variable block sizes, e.g. 9-track tapes, exabytes +and dats, "fb" is normally set to 10. +The user may override this value by setting \fIblocking_factor\fR +>= 1 or <= 10. If the device does not support variable block sizes, e.g. +various types of cartridge drives, blocks of the size defined for the +device by the "bs" parameter in the dev$tapecap file are written +and \fIblocking_factor\fR is ignored. +.le +.ls scale = yes +If the scale switch is set, the IRAF image will be scaled before output. +Two types of scaling are available. The scaling parameters bscale and +bzero may be entered by the user (autoscale = no), or the program can +calculate the appropriate bscale and bzero factors (autoscale = yes). +If the scale switch is turned off, the IRAF image data is converted +directly to integers of the specified bitpix with possible loss of +precision. +.le +.ls autoscale = yes +If the autoscale switch is set, wfits calculates the appropriate bscale and +bzero factors based on the IRAF image data type, and the maximum and minimum +values of the data. +.le +.ih +DESCRIPTION +IRAF data is read from disk and written to the specified destination, +either disk or magnetic tape. The FITS header may optionally be printed +on the standard output as either a full listing or a short description, +with or without creating an output image file. If a the default value +of bitpix (default = 0) is entered, wfits will select the appropriate +bitpix value based on the precision of the IRAF data. Otherwise the +user value is used and loss of precision is possible. Two data scaling +options are available. In autoscale mode wfits calculates the appropriate +scaling factors based on the maximum and minimum data values in the +IRAF image and the FITS bits per pixel. Alternatively the scaling factors +can be entered directly. If no scaling is requested the IRAF data values +will be converted directly to FITS integers or floating point values +with possible loss of precision. +.ih +EXAMPLES +1. Convert a list of IRAF image files to a list of FITS image files on a blank +magnetic tape, allowing wfits to select the appropriate bitpix +and scaling parameters. + +.nf + cl> wfits iraf_file* mtb1600[1] +.fi + +2. Convert a list of IRAF image files to FITS image files on disk, +allowing wfits to select the appropriate bitpix and scaling parameters. +In the first example below the images specified by the template are written +to files fits001, fits002, etc. In the second the list of input images +specified one per line in the text file imlist are written to the +files specified one per line in the text file fitslist. + +.nf + cl> wfits iraf_file* fits + + cl> wfits @imlist @fitslist +.fi + +3. Convert an IRAF image file to a 32 bits per pixel FITS file with no +scaling and append to a tape already containing data. + +.nf + cl> wfits iraf_file mtb1600[EOT] bi=32 sc- +.fi + +4. Convert an IRAF image to a 16 bit FITS image on disk, and specify +bscale and bzero explicitly in the process. + +.nf + cl> wfits iraf_file fits_file bi=16 au- bs=4.0 bz=0.0 +.fi + +5. Print the FITS headers on the standard output. + +.nf + cl> wfits iraf_file* ma- +.fi + +6. Create a disk file called headers containing the FITS headers for a list +of IRAF image files. + +.nf + cl> wfits iraf_file* ma- > headers +.fi + +7. Write a FITS tape with 14400 bytes per record (5 2880 FITS records per +tape block) on a 9-track tape. + +.nf + cl> wfits images* mtb[1] block=5 +.fi + +8. Write a FITS Exabyte tape with a blocking factor of 1 (1 2880 FITS record +per block). Note that wfits will normally by default write a 28000 ( +10 2880 FITS logical records per block) byte record. + +.nf + cl> wfits images* mtb[1] block=1 +.fi + +9. Write a list of images to a single tape file using the FITS standard +extension IMAGE. Users who are planning on reading their data with +local FITS readers should check that those local readers support the +FITS IMAGE extension before selecting this option. + +.nf + cl> wfits *.imh mtb[1] block=1 extensions+ +.fi + +10. Repeat the previous example but do not write a global header. + +.nf + cl> wfits *.imh mtb[1] block=1 extensions+ global- +.fi + +.ih +BUGS +WFITS does not attempt to recover from write errors. When an error is +detected, WFITS issues an error message and attempts to write a double +EOF at the end of the last good record. In this case the last file on +the tape will be a partial file. IF WFITS is not successful in writing +the double EOF, the message "Cannot close magtape file (name)" will be +issued. Problems occur as some drives permit the double EOF to be +written after the physical end of tape and some do not. Similarly +some drives can read a double EOF after end of tape and some cannot. Depending +on operating system and device driver, an attempt to read or write past +end of tape may or may not be distinguishable from a normal write error. + +Blank pixel values are not correctly handled. + +Attempting to write at EOT on a blank tape will at best result in numerous +error messages being issued and at worst result in tape runaway depending +on the driver. +.ih +SEE ALSO +rfits, reblock, fits kernel +.endhelp diff --git a/pkg/dataio/doc/wtextimage.hlp b/pkg/dataio/doc/wtextimage.hlp new file mode 100644 index 00000000..6dd67ff8 --- /dev/null +++ b/pkg/dataio/doc/wtextimage.hlp @@ -0,0 +1,100 @@ +.help wtextimage Oct93 dataio +.ih +NAME +wtextimage -- convert an IRAF image to a text file +.ih +USAGE +wtextimage input output +.ih +PARAMETERS +.ls input +An IRAF image file name or template of file names to be converted. +.le +.ls output +Name or root_name of output text file. If more than one IRAF image +is being converted, the ordinal of the file in the input file list +is appended to \fIoutput\fR to generate a unique output file name. +.le +.ls header = yes +This parameter determines whether or not a descriptive header precedes +the pixels written to the text file. When \fIheader = no\fR, only +pixels values are converted; no header information is included in the +output. +.le +.ls pixels = yes +This parameter determines whether or not to write the pixels to the +text file. This can be set to no to only write out the header. +.le +.ls format = "" +Output format for each pixel. If not set by the user, the appropriate output +pixel format is determined by the image data type. +Acceptable formats are chosen from "W.D[defgz]" where w is the field width and +d specifies the precision. Fortran formats of the form [iefgz]W.D are also +acceptable. If a field width of 0 is specified, (e.g., 0.6g), +output will be free format with each output line containing as many pixels as +will fit on the line. This is the most space efficient format but requires +that the reader program be able to handle free format (list directed) input. +.le +.ls maxlinelen = 80 +The maximum number of characters output per line of text; \fBmaxlinelen\fR +must not exceed 322 characters. (Note that tasks \fIrtextimage\fR and +\fIwcardimage\fR cannot read lines of text greater than 161 characters.) +.le +.ih +DESCRIPTION +IRAF images are converted to text files with procedure \fBwtextimage\fR. +The text file written consists of an optional header optionally followed by +the pixel values. The pixels are output in FITS order, that is, the +leftmost subscript varies most rapidly. The image header is written in the +"keyword = value / comment" format of FITS. +.ih +EXAMPLES +1. Write a text file from an image section of dev$pix. The default maximum +linelength of 80 is used; an output format is specified. The header portion +of the output text is as follows: +.ls +.nf +BITPIX = 8 / 8-bit ASCII characters +NAXIS = 2 / Number of Image Dimensions +NAXIS1 = 10 / Length of axis +NAXIS2 = 10 / Length of axis +ORIGIN = 'NOAO-IRAF: WTEXTIMAGE' / +IRAF-MAX= 31431. / Max image pixel (out of date) +IRAF-MIN= 33. / Min image pixel (out of date) +IRAF-B/P= 16 / Image bits per pixel +IRAFTYPE= 'SHORT INTEGER ' / Image datatype +OBJECT = 'NGC 4147 B 1800 ' / +FILENAME= 'DEV$PIX[1:10,1:10]' / IRAF filename +FORMAT = '11I7 ' / Text line format +DATA-TYP= ' object ( 0 )' / object,dark,comp,etc. +ITIME = 1800 / integration time secs +UT = '11:23:13' / universal time +ZD = '24: 5: 0' / zenith distance +DATE-OBS= '15/02/1985' / dd/mm/yy observation +ST = '13:38:31' / sidereal time +RA = '12: 9:20' / right ascension +DEC = '18:35:35' / declination +EPOCH = .0 / epoch of RA and DEC +CAM-TEMP= -104.95 / camera temperature, deg C +DEW-TEMP= -192.96 / dewar temp, deg C +HISTORY1= 'bt= 590 bp= 0 cr= 0 dk= 0 ' +HISTORY2= 'ff= 55 fg= 0 sc= .000 bi= 51 ' +COMMENT = 'ngc 4147 b 1800' +F1POS = 2 / filter bolt I position +F2POS = 0 / filter bolt II position +END +.fi +.le + +2. Write a series of text files from the IRAF images having root name +"reduced". One text file is written for each image. + + cl> wtext reduced.* txt +.ih +TIME REQUIREMENTS +It takes almost 10 cpu minutes to convert a 512 square image of real pixels. +A 512 square image of integer pixels takes about 3 cpu minutes. +.ih +SEE ALSO +wcardimage, rtextimage, noao.onedspec.wspectext +.endhelp diff --git a/pkg/dataio/export.par b/pkg/dataio/export.par new file mode 100644 index 00000000..d39690f2 --- /dev/null +++ b/pkg/dataio/export.par @@ -0,0 +1,13 @@ +# EXPORT Task Parameter File +images,s,a,"",,,"The list of input iraf images" +binfiles,s,a,"",,,"The list of output binary files" +format,s,a,"raw",,,"The type of binary file to write { raw|list| }" +header,s,h,"yes",,,"Prepend a header describing how the data are stored?" +outtype,s,h,"",,,"Output pixel type" +outbands,s,h,"",,,"Output expressions" +interleave,i,h,0,,,"Pixel interleave type" +bswap,s,h,"no",,,"Type of byte-swapping to perform on output" +verbose,b,h,no,,,"Verbose output during conversion?" + +# Mode parameter +mode,s,h,"ql",,,"mode parameter" diff --git a/pkg/dataio/export/Notes b/pkg/dataio/export/Notes new file mode 100644 index 00000000..5e60b65a --- /dev/null +++ b/pkg/dataio/export/Notes @@ -0,0 +1,37 @@ +Things to Do: +------------- + + Help Page: +done - examples showing image operand usage +done - examples of zscale/grey/bscale/gamma funcs in complex exprs + +done - clean up output header description +done - verbose is used as terminal output and raw header flag - change +done - define 'composite' in interleave description + - format=raw for >3-D images, more detail +done? - clean up description of image list handling for large groups of + images - perhaps multiple params for operands +done - format should be a query param +??? - should 'outbands' be 'outexpr' +??? - should there be an 'append' param to append existing files +done - what happens if 3-D image passes in for builtin conversion +done - Dave's typos/comments + - note that grouping exprs in function may affect the number of + perceived expressions, e.g. "psdpi ( (b1, b2, b3), 150.0)" +done - add block() function to help page +done - add setcmap() function - this is what's currently defined as the + setlut() function. +??? - Clear up confusion about LUT and colormaps in the help page + + Source: +done - block() function fills full height of expression, not just that + height specified +done - remove constraint on image sizes all being equal +done - @param and tag.param operators need to be implemented +done - text output still needs work +done - remove xvv_initop() calls - interface violation +done - finish header output +done - is zscale() mapping the pixels NOT in the range 0-255 for gif??? +done - need to implement XWD + - need to patch xwd expr for RGB to add alpha channel + - optimize image reads from 3D images diff --git a/pkg/dataio/export/bltins/exeps.x b/pkg/dataio/export/bltins/exeps.x new file mode 100644 index 00000000..b7189896 --- /dev/null +++ b/pkg/dataio/export/bltins/exeps.x @@ -0,0 +1,537 @@ +include +include +include +include +include "../export.h" +include "../exbltins.h" + + +define SZ_EPSSTRUCT 5 +define EPS_ITEMSPERLINE Memi[$1] # no. of items per line +define EPS_HPTR Memi[$1+1] # ptr to hex digit string +define EPS_BPTR Memi[$1+2] # ptr to output buffer +define EPS_BCNT Memi[$1+3] # index into output buffer +define HEXSTR Memc[EPS_HPTR($1)+$2] +define BUF Memc[EPS_BPTR($1)+$2-1] + +define LINEWID 36 # hexstr pixels per line +define HEXITS "0123456789abcdef" # hex digits +define MARGIN 0.95 # defaults for 300 dpi +define PAGEWID 612 +define PAGEHGT 762 +define SZ_EPSBUF 8192 +define SZ_TRAILER 31 + + +# EX_EPS - Write the output image to an Encasulated PostScript file. + +procedure ex_eps (ex) + +pointer ex #i task struct pointer + +pointer eps +pointer bptr +int fd, len, flags + +int strlen() +bool streq() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if ((EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) && EX_NEXPR(ex) != 3) + call error (7, "Invalid number of expressions for EPS file.") + + # Set some of the output parameters. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Allocate the EPS structure. + iferr (call calloc (eps, SZ_EPSSTRUCT, TY_STRUCT)) + call error (0, "Error allocating eps structure.") + call calloc (EPS_HPTR(eps), 17, TY_CHAR) + call calloc (EPS_BPTR(eps), SZ_EPSBUF+SZ_TRAILER, TY_CHAR) + call strcpy (HEXITS, Memc[EPS_HPTR(eps)], 17) + EPS_BCNT(eps) = 1 + + # Now write out the header and image data. + fd = EX_FD(ex) + call fseti (fd, F_ADVICE, SEQUENTIAL) + if (bitset (flags, OF_CMAP)) { + if (streq (CMAPFILE(ex),"grayscale") || + streq (CMAPFILE(ex),"greyscale")) { + call eps_header (ex, eps, NO) + call eps_gray (ex, eps, fd, false, true) + } else { + call eps_header (ex, eps, YES) + call eps_gray (ex, eps, fd, true, false) + } + + } else if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) { + call eps_header (ex, eps, NO) + call eps_gray (ex, eps, fd, false, false) + + } else if (EX_NEXPR(ex) == 3) { + call eps_header (ex, eps, YES) + call eps_rgb (ex, eps, fd) + } + + # Flush the remaining pixels in the buffer. + call calloc (bptr, SZ_EPSBUF, TY_CHAR) + + if (mod (EPS_BCNT(eps),2) == 0) { + call amovc ("\ngrestore showpage\n%%Trailer\n\0", + BUF(eps,EPS_BCNT(eps)), SZ_TRAILER) + } else { + call amovc ("\ngrestore showpage\n%%Trailer\n", + BUF(eps,EPS_BCNT(eps)), SZ_TRAILER) + } + len = strlen (BUF(eps,1)) + call strpak (BUF(eps,1), Memc[bptr], len) + call write (fd, Memc[bptr], len / SZB_CHAR) + call flush (fd) + + # Write the EPS trailer and clean up the pointers. + call mfree (EPS_HPTR(eps), TY_CHAR) + call mfree (EPS_BPTR(eps), TY_CHAR) + call mfree (eps, TY_STRUCT) + call mfree (bptr, TY_CHAR) +end + + +# EPS_GRAY - Write a grayscale EPS file. + +procedure eps_gray (ex, eps, fd, use_cmap, is_gray) + +pointer ex #i task struct pointer +pointer eps #i postscript struct pointer +int fd #i output file descriptor +bool use_cmap #i write a false color image? +bool is_gray #i is this a grayscale cmap? + +pointer op, bop, out, cm +int i, j, k, line, percent +int len, orow, type + +pointer ex_evaluate(), ex_chtype() + +begin + # Now process the expressions and write the image. + type = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + cm = EX_CMAP(ex) + call malloc (out, EX_OCOLS(ex)+2, TY_SHORT) + do i = 1, EX_NEXPR(ex) { + + # Process each line in the image. + do j = 1, O_HEIGHT(ex,i) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - j + 1 + else + line = j + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,i)) + + # Convert to the output pixel type. + bop = ex_chtype (ex, op, type) + + # Write evaluated pixels. + call achtbs (Memc[bop], Mems[out], O_LEN(op)) + len = O_LEN(op) - 1 + if (is_gray) { + # Write a single color index as the grayscale value. + do k = 0, len + call eps_putval (eps, fd, CMAP(cm,EX_RED,Mems[out+k]+1)) + } else if (use_cmap) { + # Write index values as RGB triplets. + do k = 0, len { + call eps_putval (eps, fd, + CMAP(cm,EX_RED, Mems[out+k]+1)) + call eps_putval (eps, fd, + CMAP(cm,EX_GREEN,Mems[out+k]+1)) + call eps_putval (eps, fd, + CMAP(cm,EX_BLUE, Mems[out+k]+1)) + } + } else { + do k = 0, len + call eps_putval (eps, fd, Mems[out+k]) + } + + # Clean up the pointers. + call mfree (bop, TY_CHAR) + call evvfree (op) + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + } + call mfree (out, TY_SHORT) +end + + +# EPS_RGB - Write a RGB true color EPS file. + +procedure eps_rgb (ex, eps, fd) + +pointer ex #i task struct pointer +pointer eps #i postscript struct pointer +int fd #i output file descriptor + +pointer op, bop, out +int i, j, k, line, percent, orow, type + +pointer ex_evaluate(), ex_chtype() + +begin + # Now process the expressions and write the image. + type = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + call malloc (out, EX_OCOLS(ex)+2, TY_SHORT) + do j = 1, EX_NLINES(ex) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - j + 1 + else + line = j + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Process each line in the image. + do i = 1, EX_NEXPR(ex) { + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,i)) + + # Convert to the output pixel type. + bop = ex_chtype (ex, op, type) + + # Write evaluated pixels. + call achtbs (Memc[bop], Mems[out], O_LEN(op)) + do k = 1, O_LEN(op) + call eps_putval (eps, fd, Mems[out+k-1]) + + # Clean up the pointers. + call mfree (bop, TY_CHAR) + call evvfree (op) + } + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + call mfree (out, TY_SHORT) +end + + +# EPS_HEADER - Write the EPS header block. + +procedure eps_header (ex, eps, color) + +pointer ex #i task struct pointer +pointer eps #i EPS struct pointer +int color #i is this a color image? + +int bp, fd, cols, rows, dpi, len +int icols, irows, devpix, turnflag +real scale, pixfac, scols, srows, llx, lly + +int strlen(), stropen() + +begin + fd = EX_FD(ex) + turnflag = NO + dpi = EX_PSDPI(ex) + scale = EX_PSSCALE(ex) + cols = EX_OCOLS(ex) + rows = EX_OROWS(ex) + + # Open the buffer as a string file and print to it. + bp = stropen (BUF(eps,1), SZ_EPSBUF, TEXT_FILE) + + # See if we need to rotate the image to fit on the page. + icols = cols + irows = rows + if (cols > rows && (scale * cols) > int (PAGEWID * MARGIN)) { + turnflag = YES + cols = irows + rows = icols + } + + # Figure out size. + devpix = dpi / 72.0 + 0.5 # device pixels per unit, approx + pixfac = 72.0 / dpi * devpix # 1, approx. + scols = scale * cols * pixfac + srows = scale * rows * pixfac + + if ( scols > PAGEWID * MARGIN || srows > PAGEHGT * MARGIN ) { + if ( scols > PAGEWID * MARGIN ) { + scale = scale * PAGEWID / scols * MARGIN + scols = scale * cols * pixfac + srows = scale * rows * pixfac + } + if ( srows > PAGEHGT * MARGIN ) { + scale = scale * PAGEHGT / srows * MARGIN + scols = scale * cols * pixfac + srows = scale * rows * pixfac + } + if (EX_VERBOSE(ex) == YES) { + call printf ("\tImage too large for page, rescaled to %g\n") + call pargr (scale) + call flush (STDOUT) + } + } + + # Center it on the page. + llx = (PAGEWID - scols) / 2 + lly = (PAGEHGT - srows) / 2 + + call fprintf (bp, "%%!PS-Adobe-2.0 EPSF-2.0\n") + call fprintf (bp, "%%%%Creator: IRAF EXPORT task\n") + call fprintf (bp, "%%%%Title: %s\n") + call pargstr (BFNAME(ex)) + call fprintf (bp, "%%%%Pages: 1\n") + call fprintf (bp, "%%%%BoundingBox: %d %d %d %d\n") + call pargi (int (llx + 0.5)) + call pargi (int (lly + 0.5)) + call pargi (int (llx + scols)) + call pargi (int (lly + srows)) + call fprintf (bp, "%%%%EndComments\n") + + call fprintf (bp, "/readstring {\n") # s -- s + call fprintf (bp, " currentfile exch readhexstring pop\n") + call fprintf (bp, "} bind def\n") + + if (color == YES && !bitset (EX_OUTFLAGS(ex),OF_CMAP)) { + call eps_defcol (bp, icols) + + call fprintf (bp, "/rpicstr %d string def\n") + call pargi (icols) + call fprintf (bp, "/gpicstr %d string def\n") + call pargi (icols) + call fprintf (bp, "/bpicstr %d string def\n") + call pargi (icols) + + } else if (color == YES && bitset (EX_OUTFLAGS(ex),OF_CMAP)) { + call eps_defcol (bp, icols) + + } else { + call fprintf (bp, "/picstr %d string def\n") + call pargi (icols) + } + + call fprintf (bp, "%%%%EndProlog\n") + call fprintf (bp, "%%%%Page: 1 1\n") + call fprintf (bp, "gsave\n") + call fprintf (bp, "%g %g translate\n") + call pargr (llx) + call pargr (lly) + call fprintf (bp, "%g %g scale\n") + call pargr (scols) + call pargr (srows) + + if (turnflag == YES) { + call fprintf (bp, + "0.5 0.5 translate 90 rotate -0.5 -0.5 translate\n") + } + + call fprintf (bp, "%d %d 8\n") + call pargi (icols) + call pargi (irows) + call fprintf (bp, "[ %d 0 0 -%d 0 %d ]\n") + call pargi (icols) + call pargi (irows) + call pargi (irows) + if (color == YES) { + if (bitset (EX_OUTFLAGS(ex), OF_CMAP)) { + call fprintf (bp, "{currentfile pix readhexstring pop}\n") + call fprintf (bp, "false 3 colorimage") + } else { + call fprintf (bp, "{ rpicstr readstring }\n") + call fprintf (bp, "{ gpicstr readstring }\n") + call fprintf (bp, "{ bpicstr readstring }\n") + call fprintf (bp, "true 3 colorimage") + } + } else { + call fprintf (bp, "{ picstr readstring }\n") + call fprintf (bp, "image") + } + call flush (bp) + call strclose (bp) + + # See if we need to pad the string to write it out correctly. + len = strlen(BUF(eps,1)) + if (mod(len,2) == 1) { + BUF(eps,len+1) = '\n' + } else { + BUF(eps,len+1) = ' ' + BUF(eps,len+2) = '\n' + } + + # Now write the contents of the string buffer to the output file. + len = strlen(BUF(eps,1)) + call strpak (BUF(eps,1), BUF(eps,1), len) + call write (fd, BUF(eps,1), len / SZB_CHAR) + call aclrc (BUF(eps,1), SZ_EPSBUF) + EPS_ITEMSPERLINE(eps) = 0 +end + + +# EPS_DEFCOL - Write out code that checks if the PostScript device in question +# knows about the 'colorimage' operator. If it doesn't, it defines +# 'colorimage' in terms of image (ie, generates a greyscale image from +# RGB data). + +procedure eps_defcol (fd, len) + +int fd #i output file descriptor +int len #i length of a scanline + +begin + call fprintf (fd, "%% build a temporary dictionary\n") + call fprintf (fd, "20 dict begin\n\n") + call fprintf (fd, + "%% define string to hold a scanline's worth of data\n") + call fprintf (fd, "/pix %d string def\n\n") + call pargi (len) + + call fprintf (fd, "\n") + call fprintf (fd, "%% define 'colorimage' if it isn't defined\n") + call fprintf (fd, + "/colorimage where %% do we know about 'colorimage'?\n") + call fprintf (fd, + " { pop } %% yes: pop off the 'dict' returned\n") + call fprintf (fd, " { %% no: define one\n") + call fprintf (fd, " /colortogray { %% define an RGB->I function\n") + call fprintf (fd, + " /rgbdata exch store %% call input 'rgbdata'\n") + call fprintf (fd, " rgbdata length 3 idiv\n") + call fprintf (fd, " /npixls exch store\n") + call fprintf (fd, " /rgbindx 0 store\n") + call fprintf (fd, + " /grays npixls string store %% str to hold the result\n") + call fprintf (fd, " 0 1 npixls 1 sub {\n") + call fprintf (fd, " grays exch\n") + call fprintf (fd, + " rgbdata rgbindx get 20 mul %% Red\n") + call fprintf (fd, + " rgbdata rgbindx 1 add get 32 mul %% Green\n") + call fprintf (fd, + " rgbdata rgbindx 2 add get 12 mul %% Blue\n") + call fprintf (fd, + " add add 64 idiv %% I = .5G + .31R + .18B\n") + call fprintf (fd, " put\n") + call fprintf (fd, " /rgbindx rgbindx 3 add store\n") + call fprintf (fd, " } for\n") + call fprintf (fd, " grays\n") + call fprintf (fd, " } bind def\n\n") + + call fprintf (fd, " %% Utility procedure for colorimage operator.\n") + call fprintf (fd, + " %% This procedure takes two procedures off the\n") + call fprintf (fd, + " %% stack and merges them into a single procedure.\n\n") + + call fprintf (fd, " /mergeprocs { %% def\n") + call fprintf (fd, " dup length\n") + call fprintf (fd, " 3 -1 roll\n") + call fprintf (fd, " dup\n") + call fprintf (fd, " length\n") + call fprintf (fd, " dup\n") + call fprintf (fd, " 5 1 roll\n") + call fprintf (fd, " 3 -1 roll\n") + call fprintf (fd, " add\n") + call fprintf (fd, " array cvx\n") + call fprintf (fd, " dup\n") + call fprintf (fd, " 3 -1 roll\n") + call fprintf (fd, " 0 exch\n") + call fprintf (fd, " putinterval\n") + call fprintf (fd, " dup\n") + call fprintf (fd, " 4 2 roll\n") + call fprintf (fd, " putinterval\n") + call fprintf (fd, " } bind def\n\n") + + call fprintf (fd, " /colorimage { %% def\n") + call fprintf (fd, " pop pop %% remove 'false 3' operands\n") + call fprintf (fd, " {colortogray} mergeprocs\n") + call fprintf (fd, " image\n") + call fprintf (fd, " } bind def\n") + call fprintf (fd, " } ifelse %% end of 'false' case\n") + call fprintf (fd, "\n\n") + call flush (fd) +end + + +# EPS_PUTVAL - Put a pixel value to the output file. + +procedure eps_putval (eps, fd, sval) + +pointer eps #i EPS struct pointer +int fd #i output file descriptor +short sval #i value to write + +int val, index +char ch, nl, sp +int shifti() + +begin + # Force value to 8-bit range. + #val = max (0, min (255, sval)) + val = sval + + if (EPS_ITEMSPERLINE(eps) >= LINEWID) { + sp = ' ' + call eps_putc (eps, fd, sp) + nl = '\n' + call eps_putc (eps, fd, nl) + EPS_ITEMSPERLINE(eps) = 0 + } + + # Get the hex string equivalent of the byte. + index = shifti (val, -4) # get left 4 bits + ch = HEXSTR(eps,index) + call eps_putc (eps, fd, ch) + + index = and (val, 0FX) # get right 4 bits + ch = HEXSTR(eps,index) + call eps_putc (eps, fd, ch) + + EPS_ITEMSPERLINE(eps) = EPS_ITEMSPERLINE(eps) + 1 +end + + +# EPS_PUTC - Put a character to the buffer. This routine also flushes the +# accumulated buffer to disk once it fills. + +procedure eps_putc (eps, fd, ch) + +pointer eps #i EPS struct pointer +int fd #i file descriptor +char ch #i character to 'write' + +begin + BUF(eps,EPS_BCNT(eps)) = ch + EPS_BCNT(eps) = EPS_BCNT(eps) + 1 + + # If we're getting close to a full buffer, write it out. + # Leave some space at the end for the epilogue. + if (EPS_BCNT(eps) > SZ_EPSBUF-64) { + call strpak (BUF(eps,1), BUF(eps,1), EPS_BCNT(eps)) + call write (fd, BUF(eps,1), EPS_BCNT(eps) / SZB_CHAR) + #call aclrc (BUF(eps,1), SZ_EPSBUF) + EPS_BCNT(eps) = 1 + } +end diff --git a/pkg/dataio/export/bltins/exgif.x b/pkg/dataio/export/bltins/exgif.x new file mode 100644 index 00000000..462b70e4 --- /dev/null +++ b/pkg/dataio/export/bltins/exgif.x @@ -0,0 +1,557 @@ +include +include +include +include "../export.h" +include "../exbltins.h" + + +define SZ_GIFSTRUCT 30 + +define GIF_INIT_BITS Memi[$1] # initial number of bits +define GIF_MAXCODE Memi[$1+1] # max output code +define GIF_FREE_ENT Memi[$1+2] # first unused entry +define GIF_OFFSET Memi[$1+3] # offset into output buffer +define GIF_IN_COUNT Memi[$1+4] # length of input +define GIF_CUR_BITS Memi[$1+5] # current no. bits in code +define GIF_N_BITS Memi[$1+6] # no. of max bits +define GIF_CUR_ACCUM Memi[$1+7] # current accumulator +define GIF_A_COUNT Memi[$1+8] # no. of chars in 'packet' +define GIF_CLEAR_CODE Memi[$1+9] # clear hash table code +define GIF_EOF_CODE Memi[$1+10] # EOF code +define GIF_CLEAR_FLAG Memi[$1+11] # hash table has been cleared? +define GIF_CURX Memi[$1+12] # current 'x' position in image +define GIF_CURY Memi[$1+13] # current 'y' position in image +define GIF_PASS Memi[$1+14] # interlacing pass number +define GIF_WIDTH Memi[$1+15] # width of output image +define GIF_HEIGHT Memi[$1+16] # height of output image +define GIF_EXPNUM Memi[$1+17] # expression we're evaluating +define GIF_LNUM Memi[$1+18] # line w/in that expression +define GIF_NPIX Memi[$1+19] # no. of pixels to process +define GIF_PERCENT Memi[$1+20] # percent of file completed + +define GIF_CDPTR Memi[$1+25] # compressed data (ptr) +define GIF_HPTR Memi[$1+26] # hash table (ptr) +define GIF_APTR Memi[$1+27] # packet accumulator (ptr) +define GIF_DPTR Memi[$1+28] # expression data (ptr) +define GIF_CPTR Memi[$1+29] # code table (ptr) + +define ACCUM Mems[GIF_APTR($1)+$2] +define HTAB Memi[GIF_HPTR($1)+$2] +define CODETAB Memi[GIF_CPTR($1)+$2] +define DATA Mems[GIF_DPTR($1)+$2-1] +define CDATA Mems[GIF_CDPTR($1)+$2] + +define HSIZE 5003 # 80% occupancy +define USE_INTERLACE true # Write interlaced GIF files? + +#---------------------------------------------------------------------------- +define INTERLACE 040X # Image descriptor flags +define GLOBAL_COLORMAP 080X +define LOCAL_COLORMAP 080X # (currently unused) + +# Define the flags for the GIF89a extension blocks (currently unused). +define GE_PLAINTEXT 001X # Plain Text Extension +define GE_APPLICATION 0FFX # Application Extension +define GE_COMMENT 0FEX # Comment Extension +define GE_GCONTROL 0F9X # Graphics Control Extension + + +# EX_GIF - Write the output image to a GIF 87a file. + +procedure ex_gif (ex) + +pointer ex #i task struct pointer + +pointer gif +int nbytes, flags + +char ch[2] +int or() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for GIF file.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for GIF file.") + + # Fix the output pixel type to single bytes. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Allocate the gif structure. + iferr { + call calloc (gif, SZ_GIFSTRUCT, TY_STRUCT) + call calloc (GIF_APTR(gif), 257, TY_SHORT) + call calloc (GIF_HPTR(gif), HSIZE, TY_INT) + call calloc (GIF_CPTR(gif), HSIZE, TY_INT) + call calloc (GIF_DPTR(gif), max(256,EX_OCOLS(ex)), TY_SHORT) + call calloc (GIF_CDPTR(gif), (2*EX_OROWS(ex)*EX_OCOLS(ex)),TY_SHORT) + } then + call error (0, "Error allocating gif structure.") + + GIF_WIDTH(gif) = EX_OCOLS(ex) + GIF_HEIGHT(gif) = EX_OROWS(ex) + GIF_NPIX(gif) = EX_OROWS(ex) * EX_OCOLS(ex) + GIF_CURX(gif) = 1 + GIF_CURY(gif) = 0 + GIF_PASS(gif) = 1 + GIF_EXPNUM(gif) = EX_NEXPR(ex) + GIF_LNUM(gif) = GIF_HEIGHT(gif) + + # Write the header information. + call gif_wheader (ex, EX_FD(ex)) + + # Start processing the expressions and write compressed image data. + call gif_compress (ex, gif, EX_FD(ex)) + + # Write the GIF file terminator and dump the whole thing to disk. + if (mod(GIF_OFFSET(gif),2) == 1) { + CDATA(gif,GIF_OFFSET(gif)) = '\0' + GIF_OFFSET(gif) = GIF_OFFSET(gif) + 1 + ch[1] = ';' + ch[2] = ';' + nbytes = (GIF_OFFSET(gif) + 1) / SZB_CHAR + } else { + ch[1] = '\0' + ch[2] = ';' + nbytes = GIF_OFFSET(gif) / SZB_CHAR + } + call achtsb (CDATA(gif,0), CDATA(gif,0), GIF_OFFSET(gif)) + call write (EX_FD(ex), CDATA(gif,0), nbytes) + call achtsb (ch, ch, 2) + call write (EX_FD(ex), ch, 1) + + # Clean up the pointers. + call mfree (GIF_APTR(gif), TY_SHORT) + call mfree (GIF_DPTR(gif), TY_SHORT) + call mfree (GIF_CDPTR(gif), TY_SHORT) + call mfree (GIF_HPTR(gif), TY_INT) + call mfree (GIF_CPTR(gif), TY_INT) + call mfree (gif, TY_STRUCT) +end + + +# GIF_WHEADER - Write the GIF header information. This covers not only the +# global file header but all the preliminary stuff up until the actual image +# data + +procedure gif_wheader (ex, fd) + +pointer ex #i tast struct pointer +int fd #i output file descriptor + +char sig[7] # GIF signature +char lsd[772] # Screen and Color Map information +short SWidth, SHeight # Screen width and height + +short stmp +int i, j + +int shifti(), ori() + +define GIF_SIGNATURE "GIF87a" + +begin + fd = EX_FD(ex) + + # Write the GIF signature. This is technically the "header", following + # this are the scene/color/image descriptors. + call strcpy (GIF_SIGNATURE, sig, 7) + call strpak (sig, sig, 7) + call write (fd, sig, 7/SZB_CHAR) + + # Logical Screen Descriptor. + SWidth = EX_OCOLS(ex) + SHeight = EX_OROWS(ex) + call gif_putword (fd, SWidth) + call gif_putword (fd, SHeight) + + # Set the 'packed' flags and write it out + i = 0 + i = ori (i, GLOBAL_COLORMAP) # indicate a colormap + i = ori (i, (shifti(7, 4))) # color resolution + i = ori (i, (8-1)) # bits per pixel + lsd[1] = i # packed flags + lsd[2] = 0 # background color + lsd[3] = 0 # aspect ratio + lsd[4] = 0 # filler expansion byte + + # Write out the colormap. + if (EX_CMAP(ex) != NULL) { + j = 1 + for (i=4 ; i <= 772; i=i+3) { + lsd[i ] = CMAP(EX_CMAP(ex), EX_RED, j) + lsd[i+1] = CMAP(EX_CMAP(ex), EX_GREEN, j) + lsd[i+2] = CMAP(EX_CMAP(ex), EX_BLUE, j) + j = j + 1 + } + } else { + j = 0 + for (i=4 ; i <= 772; i=i+3) { + lsd[i ] = j + lsd[i+1] = j + lsd[i+2] = j + j = j + 1 + } + } + lsd[772] = ',' + call achtcb (lsd, lsd, 772) + call write (fd, lsd, 772/SZB_CHAR) + + # Write the image header. + stmp = 0 + call gif_putword (fd, stmp) + call gif_putword (fd, stmp) + call gif_putword (fd, SWidth) + call gif_putword (fd, SHeight) + + # Next set the interlace flag and the initial code size in the next + # two bytes. + if (USE_INTERLACE) + stmp = ori (shifti(INTERLACE,8), 8) + else + stmp = 8 + if (BYTE_SWAP2 == YES) + call bswap2 (stmp, 1, stmp, 1, 2) + call write (fd, stmp, 1) +end + + +# GIF_COMPRESS - Compress the image data using a modified LZW. + +procedure gif_compress (ex, gif, fd) + +pointer ex #i tast struct pointer +pointer gif #i gif struct pointer +int fd #i output file descriptor + +long fcode +int i, c, ent, disp +int hsize_reg, hshift + +short gif_next_pixel() +int xori(), shifti() + +define probe_ 99 +define nomatch_ 98 + +begin + GIF_INIT_BITS(gif) = 9 # initialize + GIF_N_BITS(gif) = 9 + GIF_OFFSET(gif) = 0 + GIF_CLEAR_FLAG(gif) = NO + GIF_IN_COUNT(gif) = 1 + GIF_MAXCODE(gif) = 511 + GIF_CLEAR_CODE(gif) = 256 + GIF_EOF_CODE(gif) = GIF_CLEAR_CODE(gif) + 1 + GIF_FREE_ENT(gif) = GIF_CLEAR_CODE(gif) + 2 + GIF_A_COUNT(gif) = 0 + + ent = gif_next_pixel (ex, gif) + hshift = 0 + for (fcode = HSIZE; fcode < 65536 ; fcode = fcode * 2) + hshift = hshift + 1 + hshift = 8-hshift # set hash code range bound + + hsize_reg = HSIZE # clear the hash table + call amovki (-1, HTAB(gif,0), HSIZE) + + call gif_output (fd, gif, GIF_CLEAR_CODE(gif)) + + # Now loop over the pixels. + repeat { + c = gif_next_pixel (ex, gif) + if (c == EOF) + break + GIF_IN_COUNT(gif) = GIF_IN_COUNT(gif) + 1 + + fcode = shifti (c, 12) + ent + i = xori (shifti (c, hshift), ent) + + if (HTAB(gif,i) == fcode) { + ent = CODETAB(gif,i) + next + } else if (HTAB(gif,i) < 0) # empty slot + goto nomatch_ + disp = hsize_reg - i # secondary hash (after G. Knott) + if (i == 0) + disp = 1 + +probe_ i = i - disp + if (i < 0) + i = i + hsize_reg + + if (HTAB(gif,i) == fcode) { + ent = CODETAB(gif,i) + next + } + if (HTAB(gif,i) >= 0) + goto probe_ + +nomatch_ call gif_output (fd, gif, ent) + ent = c + if (GIF_FREE_ENT(gif) < 4096) { + CODETAB(gif,i) = GIF_FREE_ENT(gif) + GIF_FREE_ENT(gif) = GIF_FREE_ENT(gif) + 1 + HTAB(gif,i) = fcode + } else { + # Clear out the hash table. + call amovki (-1, HTAB(gif,0), HSIZE) + GIF_FREE_ENT(gif) = GIF_CLEAR_CODE(gif) + 2 + GIF_CLEAR_FLAG(gif) = YES + call gif_output (fd, gif, GIF_CLEAR_CODE(gif)) + } + } + + # Write out the final code. + call gif_output (fd, gif, ent) + call gif_output (fd, gif, GIF_EOF_CODE(gif)) +end + + +# GIF_NEXT_PIXEL - Writes a 16-bit integer in GIF order (LSB first). + +short procedure gif_next_pixel (ex, gif) + +pointer ex #i tast struct pointer +pointer gif #i gif struct pointer + +short pix +pointer op, out +pointer ex_chtype(), ex_evaluate() + +begin + if (GIF_NPIX(gif) == 0) + return (EOF) + + # If the current X position is at the start of a line get the new + # data, otherwise just return what we already know. + pix = 1 + if (GIF_CURX(gif) == 1) { + call ex_getpix (ex, GIF_LNUM(gif)) + op = ex_evaluate (ex, O_EXPR(ex,GIF_EXPNUM(gif))) + out = ex_chtype (ex, op, TY_UBYTE) + call aclrs (DATA(gif,1), O_LEN(op)) + call achtbu (Memc[out], DATA(gif,1), O_LEN(op)) + call mfree (out, TY_CHAR) + call evvfree (op) + } + pix = DATA(gif,GIF_CURX(gif)) + + # Increment the position. + if (GIF_CURY(gif) == EX_OROWS(ex)) { + GIF_CURX(gif) = min (EX_OCOLS(ex), GIF_CURX(gif) + 1) + } else + call gif_bump_pixel (ex, gif) + + GIF_NPIX(gif) = GIF_NPIX(gif) - 1 + return (pix) +end + + +# GIF_BUMP_PIXEL - Update the current x and y values for interlacing. + +procedure gif_bump_pixel (ex, gif) + +pointer ex #i tast struct pointer +pointer gif #i gif struct pointer + +int i, row, sum + +begin + GIF_CURX(gif) = GIF_CURX(gif) + 1 + + # If we are at the end of a scan line, set curx back to the beginning + # Since we are interlaced, bump the cury to the appropriate spot. + + if (GIF_CURX(gif) > GIF_WIDTH(gif)) { + GIF_CURX(gif) = 1 + + if (USE_INTERLACE) { + switch (GIF_PASS(gif)) { + case 1: + GIF_CURY(gif) = GIF_CURY(gif) + 8 + if (GIF_CURY(gif) >= GIF_HEIGHT(gif)) { + GIF_PASS(gif) = GIF_PASS(gif) + 1 + GIF_CURY(gif) = 4 + } + case 2: + GIF_CURY(gif) = GIF_CURY(gif) + 8 + if (GIF_CURY(gif) >= GIF_HEIGHT(gif)) { + GIF_PASS(gif) = GIF_PASS(gif) + 1 + GIF_CURY(gif) = 2 + } + case 3: + GIF_CURY(gif) = GIF_CURY(gif) + 4 + if (GIF_CURY(gif) >= GIF_HEIGHT(gif)) { + GIF_PASS(gif) = GIF_PASS(gif) + 1 + GIF_CURY(gif) = 1 + } + case 4: + GIF_CURY(gif) = GIF_CURY(gif) + 2 + if (GIF_CURY(gif) >= GIF_HEIGHT(gif)) { + GIF_EXPNUM(gif) = EX_NEXPR(ex) + GIF_LNUM(gif) = EX_OROWS(ex) + GIF_CURY(gif) = GIF_HEIGHT(gif) + return + } + } + + # Now figure out where we are in the expressions. + i = EX_NEXPR(ex) + sum = GIF_HEIGHT(gif) + while (sum >= GIF_CURY(gif)) { + sum = sum - O_HEIGHT(ex,i) + i = i - 1 + } + GIF_EXPNUM(gif) = i + 1 + GIF_LNUM(gif) = (sum + O_HEIGHT(ex,i+1)) - GIF_CURY(gif) + 1 + + row = ((EX_OROWS(ex) * EX_OCOLS(ex)) - GIF_NPIX(gif)) / + EX_OCOLS(ex) + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, row, GIF_PERCENT(gif)) + + } else { + GIF_CURY(gif) = GIF_CURY(gif) + 1 + + # Now figure out where we are in the expressions. + i = EX_NEXPR(ex) + sum = GIF_HEIGHT(gif) + while (sum >= GIF_CURY(gif)) { + sum = sum - O_HEIGHT(ex,i) + i = i - 1 + } + + if ((i+1) == GIF_EXPNUM(gif)) { + GIF_LNUM(gif) = GIF_LNUM(gif) - 1 + } else { + GIF_EXPNUM(gif) = i + 1 + GIF_LNUM(gif) = O_HEIGHT(ex,i+1) + } + + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, GIF_CURY(gif), GIF_PERCENT(gif)) + } + } +end + + +# GIF_OUTPUT - Output the given code. + +procedure gif_output (fd, gif, code) + +int fd #i output file descriptor +pointer gif #i gif struct pointer +int code #i code to output + +long masks[17] +int i + +int ori(), andi(), shifti() + +data (masks(i), i=1,5) /00000X, 00001X, 00003X, 00007X, 0000FX/ +data (masks(i), i=6,9) /0001FX, 0003FX, 0007FX, 000FFX/ +data (masks(i), i=10,13) /001FFX, 003FFX, 007FFX, 00FFFX/ +data (masks(i), i=14,17) /01FFFX, 03FFFX, 07FFFX, 0FFFFX/ + +begin + GIF_CUR_ACCUM(gif) = andi(GIF_CUR_ACCUM(gif),masks[GIF_CUR_BITS(gif)+1]) + + if (GIF_CUR_BITS(gif) > 0) + GIF_CUR_ACCUM(gif) = ori (GIF_CUR_ACCUM(gif), + shifti (code, GIF_CUR_BITS(gif))) + else + GIF_CUR_ACCUM(gif) = code + GIF_CUR_BITS(gif) = GIF_CUR_BITS(gif) + GIF_N_BITS(gif) + + while (GIF_CUR_BITS(gif) >= 8) { + call char_out (fd, gif, andi (GIF_CUR_ACCUM(gif), 0FFX)) + GIF_CUR_ACCUM(gif) = shifti (GIF_CUR_ACCUM(gif), -8) + GIF_CUR_BITS(gif) = GIF_CUR_BITS(gif) - 8 + } + + # If the next entry is going to be too big for the code size then + # increase it if possible. + if (GIF_FREE_ENT(gif) > GIF_MAXCODE(gif) || GIF_CLEAR_FLAG(gif)==YES) { + if (GIF_CLEAR_FLAG(gif) == YES) { + GIF_MAXCODE(gif) = 511 + GIF_N_BITS(gif) = 9 + GIF_CLEAR_FLAG(gif) = NO + } else { + GIF_N_BITS(gif) = GIF_N_BITS(gif) + 1 + if (GIF_N_BITS(gif) == 12) + GIF_MAXCODE(gif) = 4096 + else + GIF_MAXCODE(gif) = shifti (1, GIF_N_BITS(gif)) - 1 + } + } + + if (code == GIF_EOF_CODE(gif)) { + # At EOF, write the rest of the buffer. + while (GIF_CUR_BITS(gif) >= 8) { + call char_out (fd, gif, andi (GIF_CUR_ACCUM(gif), 0FFX)) + GIF_CUR_ACCUM(gif) = shifti (GIF_CUR_ACCUM(gif), -8) + GIF_CUR_BITS(gif) = GIF_CUR_BITS(gif) - 8 + } + + call flush_char (gif) + call flush (fd) + } +end + + +# GIF_PUTWORD - Writes a 16-bit integer in GIF order (LSB first). + +procedure gif_putword (fd, w) + +int fd +short w + +short val +int tmp, shifti() + +begin + # If this is a MSB-first machine swap the bytes before output. + if (BYTE_SWAP2 == NO) { + call bitpak (int(w), tmp, 9, 8) + call bitpak (shifti(int(w),-8), tmp, 1, 8) + val = tmp + } else + val = w + + call write (fd, val, SZ_SHORT/SZ_CHAR) +end + + +procedure char_out (fd, gif, c) + +int fd #i output file descriptor +pointer gif #i gif struct pointer +int c #i char to output + +begin + ACCUM(gif,GIF_A_COUNT(gif)) = c + GIF_A_COUNT(gif) = GIF_A_COUNT(gif) + 1 + if (GIF_A_COUNT(gif) >= 254) + call flush_char (gif) +end + + +procedure flush_char (gif) + +pointer gif #i gif struct pointer + +begin + if (GIF_A_COUNT(gif) > 0) { + CDATA(gif,GIF_OFFSET(gif)) = GIF_A_COUNT(gif) + GIF_OFFSET(gif) = GIF_OFFSET(gif) + 1 + call amovs (ACCUM(gif,0), CDATA(gif,GIF_OFFSET(gif)), + GIF_A_COUNT(gif)) + GIF_OFFSET(gif) = GIF_OFFSET(gif) + GIF_A_COUNT(gif) + GIF_A_COUNT(gif) = 0 + } +end diff --git a/pkg/dataio/export/bltins/exiraf.x b/pkg/dataio/export/bltins/exiraf.x new file mode 100644 index 00000000..282cf383 --- /dev/null +++ b/pkg/dataio/export/bltins/exiraf.x @@ -0,0 +1,110 @@ +include +include +include +include "../export.h" + + +# EX_IRAF - Write the evaluated expressions back out as an IRAF image. + +procedure ex_iraf (ex) + +pointer ex #i task struct pointer + +pointer sp, imname +pointer im, op, out +int i, j, flags +int line, percent, orow, type + +pointer ex_evaluate(), ex_chtype() +pointer immap() +pointer impl2s(), impl2i(), impl2l(), impl2r(), impl2d() +int fnroot() + +errchk immap + +begin + # Check to see that we have the correct number of expressions. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for IRAF image.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for IRAF image.") + if (EX_OUTTYPE(ex) == TY_UBYTE) + call ex_do_outtype (ex, "u2") + + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call aclrc (Memc[imname], SZ_FNAME) + + # Since we're writing an image, close the output file descriptor + # and instead use an image pointer. + call close (EX_FD(ex)) + call delete (BFNAME(ex)) + EX_FD(ex) = NULL + + # Generate the image name and map it for processing. + if (fnroot (BFNAME(ex), Memc[imname], SZ_FNAME) == 0) + call error (0, "Error making image name.") + iferr (im = immap (Memc[imname], NEW_IMAGE, 0)) + call error (0, "Error mapping output image.") + + # Set the minimal header values. + IM_LEN(im,1) = EX_OCOLS(ex) + IM_LEN(im,2) = EX_OROWS(ex) + IM_NDIM(im) = 2 + IM_PIXTYPE(im) = EX_OUTTYPE(ex) + + # Finally, evaluate the expressions and write the image. + type = EX_OUTTYPE(ex) + percent = 0 + orow = 1 + do i = 1, EX_NEXPR(ex) { + + # Process each line in the image. + do j = 1, O_HEIGHT(ex,i) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - j + 1 + else + line = j + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,i)) + + # Convert to the output pixel type. + out = ex_chtype (ex, op, type) + + # Write evaluated pixels. + switch (type) { + case TY_USHORT, TY_SHORT: + call amovs (Mems[out], Mems[impl2s(im,orow)], O_LEN(op)) + case TY_INT: + call amovi (Memi[out], Memi[impl2i(im,orow)], O_LEN(op)) + case TY_LONG: + call amovl (Meml[out], Meml[impl2l(im,orow)], O_LEN(op)) + case TY_REAL: + call amovr (Memr[out], Memr[impl2r(im,orow)], O_LEN(op)) + case TY_DOUBLE: + call amovd (Memd[out], Memd[impl2d(im,orow)], O_LEN(op)) + default: + call error (0, "Illegal output image type.") + } + + # Clean up the pointers. + call mfree (out, type) + call evvfree (op) + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + } + + call imunmap (im) + call sfree (sp) +end diff --git a/pkg/dataio/export/bltins/exmiff.x b/pkg/dataio/export/bltins/exmiff.x new file mode 100644 index 00000000..9e5756e5 --- /dev/null +++ b/pkg/dataio/export/bltins/exmiff.x @@ -0,0 +1,81 @@ +include +include "../export.h" + + +# EX_MIFF - Write the evaluated expressions as an ImageMagick MIFF format file. + +procedure ex_miff (ex) + +pointer ex #i task struct pointer + +pointer sp, hdr, cmap +int i, j, flags +char ncols[6] + +int strlen() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 3 && EX_NEXPR(ex) != 1) + call error (7, "Invalid number of expressions for MIFF file.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for MIFF file.") + + # Write the header to the file. + call smark (sp) + call salloc (hdr, SZ_COMMAND, TY_CHAR) + call aclrc (Memc[hdr], SZ_COMMAND) + + call sprintf (ncols, 6, "%d") + call pargi (EX_NCOLORS(ex)) + call sprintf (Memc[hdr], SZ_COMMAND, + "{\nCreated by IRAF EXPORT Task\n}\nid=ImageMagick\nclass=%s %s%s\ncolumns=%-5d rows=%-5d\n\f\n:\n") + + if (EX_NEXPR(ex) == 3) { + call pargstr ("DirectClass") + call pargstr ("") + call pargstr ("") + } else { + call pargstr ("PseudoClass") + if (bitset (flags,OF_CMAP)) { + call pargstr ("colors=") + call pargstr (ncols) + } else { + call pargstr ("") + call pargstr ("") + } + } + call pargi (EX_OCOLS(ex)) + call pargi (EX_OROWS(ex)) + + if (mod(strlen(Memc[hdr]),2) == 1) + call strcat ("\n", Memc[hdr], SZ_COMMAND) + call strpak (Memc[hdr], Memc[hdr], SZ_COMMAND) + call write (EX_FD(ex), Memc[hdr], strlen(Memc[hdr])/SZB_CHAR) + + # Finally, evaluate the expressions and write the image. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + if (bitset (flags,OF_CMAP)) { + # Write out the colormap. + call salloc (cmap, 3*CMAP_SIZE, TY_CHAR) + j = 1 + do i = 0, (3*CMAP_SIZE-1), 3 { + Memc[cmap+i+0] = CMAP(EX_CMAP(ex), EX_RED, j) + Memc[cmap+i+1] = CMAP(EX_CMAP(ex), EX_GREEN, j) + Memc[cmap+i+2] = CMAP(EX_CMAP(ex), EX_BLUE, j) + j = j + 1 + } + call achtcb (Memc[cmap], Memc[cmap], (3 * CMAP_SIZE)) + call write (EX_FD(ex), Memc[cmap], ((3 * CMAP_SIZE) / SZB_CHAR)) + + call ex_no_interleave (ex) # write the pixels + + } else + call ex_px_interleave (ex) + + call sfree (sp) +end diff --git a/pkg/dataio/export/bltins/expgm.x b/pkg/dataio/export/bltins/expgm.x new file mode 100644 index 00000000..c8a7a1d7 --- /dev/null +++ b/pkg/dataio/export/bltins/expgm.x @@ -0,0 +1,47 @@ +include +include "../export.h" + + +# EX_PGM - Write the evaluated expressions as a PGM format file. + +procedure ex_pgm (ex) + +pointer ex #i task struct pointer + +pointer sp, hdr +int len, flags + +int strlen() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for PGM file.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for PGM file.") + + # Write the header to the file. + call smark (sp) + call salloc (hdr, SZ_LINE, TY_CHAR) + call aclrc (Memc[hdr], SZ_LINE) + + call sprintf (Memc[hdr], SZ_LINE, "P5\n%-6d %-6d\n255\n") + call pargi (EX_OCOLS(ex) - mod (EX_OCOLS(ex),2)) + call pargi (EX_OROWS(ex)) + len = strlen (Memc[hdr]) + call strpak (Memc[hdr], Memc[hdr], SZ_LINE) + call write (EX_FD(ex), Memc[hdr], len/SZB_CHAR) + call sfree (sp) + + # Fix the output pixel type to single bytes. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Finally, evaluate the expressions and write the image. + if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) + call ex_no_interleave (ex) + else + call error (7, "Shouldn't be here.") +end diff --git a/pkg/dataio/export/bltins/exppm.x b/pkg/dataio/export/bltins/exppm.x new file mode 100644 index 00000000..4dab4727 --- /dev/null +++ b/pkg/dataio/export/bltins/exppm.x @@ -0,0 +1,49 @@ +include +include "../export.h" + + +# EX_PPM - Write the evaluated expressions as a PPM format file. + +procedure ex_ppm (ex) + +pointer ex #i task struct pointer + +pointer sp, hdr +int len, flags + +int strlen() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 3) + call error (7, "Invalid number of expressions for PPM file.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for PPM file.") + + # Write the header to the file. + call smark (sp) + call salloc (hdr, SZ_LINE, TY_CHAR) + call aclrc (Memc[hdr], SZ_LINE) + + # If we have an odd number of pixels we can't correctly write the + # last column to the file, so truncate the column in the output image. + if (mod (EX_NCOLS(ex),2) == 1) + EX_OCOLS(ex) = EX_OCOLS(ex) - 1 + + call sprintf (Memc[hdr], SZ_LINE, "P6\n%-6d %-6d\n255\n") + call pargi (EX_OCOLS(ex)) + call pargi (EX_OROWS(ex)) + len = strlen (Memc[hdr]) + call strpak (Memc[hdr], Memc[hdr], SZ_LINE) + call write (EX_FD(ex), Memc[hdr], len/SZB_CHAR) + call sfree (sp) + + # Fix the output pixel type to single bytes. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Finally, evaluate the expressions and write the image. + call ex_px_interleave (ex) +end diff --git a/pkg/dataio/export/bltins/exras.x b/pkg/dataio/export/bltins/exras.x new file mode 100644 index 00000000..f24209c6 --- /dev/null +++ b/pkg/dataio/export/bltins/exras.x @@ -0,0 +1,117 @@ +include +include "../export.h" + + +# EXRAS.X - Source file for the EXPORT task rasterfile builtin format. + +define SZ_RASHDR 8 +define RAS_MAGIC 1 # Magic number +define RAS_WIDTH 2 # Image width (pixels per line) +define RAS_HEIGHT 3 # Image height (number of lines) +define RAS_DEPTH 4 # Image depth (bits per pixel) +define RAS_LENGTH 5 # Image length (bytes) +define RAS_TYPE 6 # File type +define RAS_MAPTYPE 7 # Colormap type +define RAS_MAPLENGTH 8 # Colormap length (bytes) + +# Rasterfile magic number +define RAS_MAGIC_NUM 59A66A95X +define RAS_RLE 80X + +# Sun supported ras_types +define RT_OLD 0 # Raw pixrect image in 68000 byte order +define RT_STANDARD 1 # Raw pixrect image in 68000 byte order +define RT_BYTE_ENCODED 2 # Run-length compression of bytes +define RT_FORMAT_RGB 3 # XRGB or RGB instead of XBGR or BGR +define RT_FORMAT_TIFF 4 # tiff <-> standard rasterfile +define RT_FORMAT_IFF 5 # iff (TAAC format) <-> standard rasterfile +define RT_EXPERIMENTAL 65535 # Reserved for testing + +# Sun supported ras_maptypes +define RMT_NONE 0 # ras_maplength is expected to be 0 +define RMT_EQUAL_RGB 1 # red[ras_maplength/3],green[],blue[] +define RMT_RAW 2 + + + +# EX_RAS - Write the evaluated expressions as a Sun Rasterfile. + +procedure ex_ras (ex) + +pointer ex #i task struct pointer + +pointer sp, cmap +long header[SZ_RASHDR] +int i, flags + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 1 && EX_NEXPR(ex) != 3 && EX_NEXPR(ex) != 4) { + if (!bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for rasterfile.") + } + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for rasterfile.") + + # Fix the output pixel type to single bytes. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Make sure the output is padded to the nearest 16-bits. + if (mod (O_WIDTH(ex,1),2) != 0) { + do i = 1, EX_NEXPR(ex) { + call strcat ("//repl(0,1)", O_EXPR(ex,i), SZ_EXPSTR) + O_WIDTH(ex,i) = O_WIDTH(ex,i) + 1 + } + EX_OCOLS(ex) = EX_OCOLS(ex) + 1 + } + + # Set the header values. + header[RAS_MAGIC] = RAS_MAGIC_NUM + header[RAS_WIDTH] = EX_OCOLS(ex) + header[RAS_HEIGHT] = EX_OROWS(ex) + header[RAS_TYPE] = RT_STANDARD + if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) { + header[RAS_LENGTH] = header[RAS_WIDTH] * header[RAS_HEIGHT] + header[RAS_DEPTH] = long (8) + } else { + header[RAS_LENGTH] = header[RAS_WIDTH] * header[RAS_HEIGHT] * 3 + header[RAS_DEPTH] = long (24) + header[RAS_TYPE] = RT_FORMAT_RGB + } + if (bitset(flags, OF_CMAP)) { + header[RAS_MAPTYPE] = RMT_EQUAL_RGB + header[RAS_MAPLENGTH] = long (3*CMAP_SIZE) + } else { + header[RAS_MAPTYPE] = RMT_NONE + header[RAS_MAPLENGTH] = long (0) + } + + # Write the header to the file. First swap it to Sun byte order if + # needed (although the format doesn't require this), then swap it + # if requested by the user. + if (BYTE_SWAP4 == YES) + call bswap4 (header, 1, header, 1, (SZ_RASHDR * SZ_LONG * SZB_CHAR)) + if (EX_BSWAP(ex) == S_I4) + call bswap4 (header, 1, header, 1, (SZ_RASHDR * SZ_LONG * SZB_CHAR)) + call write (EX_FD(ex), header, (SZ_RASHDR * SZ_LONG)) + + # If we have a colormap write that out now. + if (bitset(flags, OF_CMAP)) { + call smark (sp) + call salloc (cmap, 3*CMAP_SIZE, TY_CHAR) + + call achtcb (Memc[EX_CMAP(ex)], Memc[cmap], (3 * CMAP_SIZE)) + call write (EX_FD(ex), Memc[cmap], ((3 * CMAP_SIZE) / SZB_CHAR)) + + call sfree (sp) + } + + # Finally, evaluate the expressions and write the image. + if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) + call ex_no_interleave (ex) + else if (EX_NEXPR(ex) == 3 || EX_NEXPR(ex) == 4) + call ex_px_interleave (ex) +end diff --git a/pkg/dataio/export/bltins/exrgb.x b/pkg/dataio/export/bltins/exrgb.x new file mode 100644 index 00000000..119168e6 --- /dev/null +++ b/pkg/dataio/export/bltins/exrgb.x @@ -0,0 +1,74 @@ +include +include "../export.h" +include "../exbltins.h" + + +define IMAGIC 0732B # SGI magic number +define BPPMASK 00FFX +define ITYPE_VERBATIM 0001X +define ITYPE_RLE 0100X + + +# EX_RGB - Write the output image to an SGI RGB format file. + +procedure ex_rgb (ex) + +pointer ex #i task struct pointer + +int i, fd +short imagic, type, dim # stuff saved on disk +short xsize, ysize, zsize, pad +long min, max +char name[80] + +begin + # Check to see that we have the correct number of expressions to + # write this format. + if (EX_NEXPR(ex) != 3) + call error (7, "Invalid number of expressions for SGI RGB.") + + # Fix up the number of output rows. + EX_OROWS(ex) = EX_NLINES(ex) * EX_NEXPR(ex) + + # Load the image header values + imagic = IMAGIC + type = ITYPE_VERBATIM + if (EX_NEXPR(ex) >= 3 && !bitset (EX_OUTFLAGS(ex),OF_BAND)) { + dim = 3 + zsize = 3 + } else { + dim = 2 + zsize = 1 + } + xsize = EX_OCOLS(ex) + ysize = EX_NLINES(ex) + min = 0 + max = 255 + call aclrc (name, 80) + call strcpy ("no name", name, 80) + call achtcb (name, name, 80) + + # Write the header values to the output file. + fd = EX_FD(ex) + call write (fd, imagic, SZ_SHORT / SZ_CHAR) + call write (fd, type, SZ_SHORT / SZ_CHAR) + call write (fd, dim, SZ_SHORT / SZ_CHAR) + call write (fd, xsize, SZ_SHORT / SZ_CHAR) + call write (fd, ysize, SZ_SHORT / SZ_CHAR) + call write (fd, zsize, SZ_SHORT / SZ_CHAR) + call write (fd, min, SZ_LONG / SZ_CHAR) + call write (fd, max, SZ_LONG / SZ_CHAR) + call write (fd, 0, SZ_LONG / SZ_CHAR) + call write (fd, name, 8 / SZB_CHAR) + + # Pad to a 512 byte header. + pad = 0 + do i = 1, 240 + call write (fd, pad, SZ_SHORT / SZ_CHAR) + + # Fix the output parameters. + call ex_do_outtype (ex, "b1") + + # Write it out. + call ex_no_interleave (ex) +end diff --git a/pkg/dataio/export/bltins/exvicar.x b/pkg/dataio/export/bltins/exvicar.x new file mode 100644 index 00000000..31c8360f --- /dev/null +++ b/pkg/dataio/export/bltins/exvicar.x @@ -0,0 +1,111 @@ +include +include "../export.h" + + +define SZ_VICHDR 1024 + + +# EX_VICAR - Write the evaluated expressions as a VICAR2 format file. + +procedure ex_vicar (ex) + +pointer ex #i task struct pointer + +pointer sp, hdr, user, date, arch +int i, flags +char space + +int envfind(), strncmp(), strlen() +long clktime() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for VICAR file.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for VICAR file.") + + # Write the header to the file. + call smark (sp) + call salloc (hdr, SZ_VICHDR, TY_CHAR) + call salloc (user, SZ_FNAME, TY_CHAR) + call salloc (date, SZ_FNAME, TY_CHAR) + call salloc (arch, SZ_FNAME, TY_CHAR) + + space = ' ' + call amovkc (space, Memc[hdr], SZ_VICHDR) + call aclrc (Memc[user], SZ_FNAME) + call aclrc (Memc[date], SZ_FNAME) + call aclrc (Memc[arch], SZ_FNAME) + + # Header keywords: + call getuid (Memc[user], SZ_FNAME) + call cnvtime (clktime(long(0)), Memc[date], SZ_FNAME) + call sprintf (Memc[hdr], SZ_VICHDR, + "LBLSIZE=%d FORMAT='%s' TYPE='IMAGE' BUFSIZ=20480 DIM=3 EOL=0 RECSIZE=%d ORG='%s' NL=%d NS=%d NB=%d N1=%d N2=%d N3=%d N4=0 NBB=0 NLB=0 INTFMT='%s' REALFMT='%s' TASK='EXPORT' USER='%s' DAT_TIM='%s' ") + + call pargi (SZ_VICHDR) # LBLSIZE + switch (EX_OUTTYPE(ex)) { # FORMAT + case TY_UBYTE: call pargstr ("BYTE") + case TY_SHORT: call pargstr ("HALF") + case TY_INT: call pargstr ("FULL") + case TY_LONG: call pargstr ("FULL") + case TY_REAL: call pargstr ("REAL") + case TY_DOUBLE: call pargstr ("DOUB") + } + call pargi (EX_OCOLS(ex)) # RECSIZE + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call pargstr ("BIL") # ORG + else + call pargstr ("BSQ") + call pargi (EX_OROWS(ex)) # NL + call pargi (EX_OCOLS(ex)) # NS + call pargi (EX_NEXPR(ex)) # NB + call pargi (EX_OCOLS(ex)) # N1 + call pargi (EX_OROWS(ex)) # N2 + call pargi (EX_NEXPR(ex)) # N3 + if (BYTE_SWAP2 == NO) + call pargstr ("HIGH") # INTFMT + else + call pargstr ("LOW") + if (IEEE_USED == YES) { # REALFMT + if (envfind ("arch", Memc[arch], SZ_FNAME) != ERR) { + # If this is a DECstation we have a different IEEE. + if (strncmp(Memc[arch], ".d", 2) == 0) + call pargstr ("RIEEE") + else + call pargstr ("IEEE") + } + } else { + # Assume it's a VAX. + call pargstr ("VAX") + } + call pargstr (Memc[user]) # USER + call pargstr (Memc[date]) # DAT_TIM + + i = SZ_VICHDR + while (Memc[hdr+i-1] != EOS && i > 0) + i = i - 1 + Memc[hdr+i-1] = ' ' + + call strpak (Memc[hdr], Memc[hdr], SZ_VICHDR) + call write (EX_FD(ex), Memc[hdr], strlen(Memc[hdr])/SZB_CHAR) + call sfree (sp) + + # Fix the output pixel type to single bytes. + switch (EX_OUTTYPE(ex)) { + case TY_UBYTE: call ex_do_outtype (ex, "b1") + case TY_SHORT: call ex_do_outtype (ex, "i2") + case TY_INT: call ex_do_outtype (ex, "i4") + case TY_LONG: call ex_do_outtype (ex, "i4") + case TY_REAL: call ex_do_outtype (ex, "n4") + case TY_DOUBLE: call ex_do_outtype (ex, "n8") + } + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Finally, evaluate the expressions and write the image. + if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) + call ex_no_interleave (ex) +end diff --git a/pkg/dataio/export/bltins/exxwd.x b/pkg/dataio/export/bltins/exxwd.x new file mode 100644 index 00000000..08c4609a --- /dev/null +++ b/pkg/dataio/export/bltins/exxwd.x @@ -0,0 +1,253 @@ +include +include "../export.h" +include "../exbltins.h" + + +define X11WD_FILE_VERSION 7 # XWD version +define SZ_XWD 25 # number of header elements +define SZ_XWDHEADER 100 # size of header record (bytes) + +# Define the header structure. +define X_HEADER_SIZE Meml[$1] # Size of the header (bytes) +define X_FILE_VERSION Meml[$1+1] # XWD_FILE_VERSION +define X_PIXMAP_FORMAT Meml[$1+2] # Pixmap format +define X_PIXMAP_DEPTH Meml[$1+3] # Pixmap depth +define X_PIXMAP_WIDTH Meml[$1+4] # Pixmap width +define X_PIXMAP_HEIGHT Meml[$1+5] # Pixmap height +define X_XOFFSET Meml[$1+6] # Bitmap x offset +define X_BYTE_ORDER Meml[$1+7] # MSBFirst, LSBFirst +define X_BITMAP_UNIT Meml[$1+8] # Bitmap unit +define X_BITMAP_BIT_ORDER Meml[$1+9] # MSBFirst, LSBFirst +define X_BITMAP_PAD Meml[$1+10] # Bitmap scanline pad +define X_BITS_PER_PIXEL Meml[$1+11] # Bits per pixel +define X_BYTES_PER_LINE Meml[$1+12] # Bytes per scanline +define X_VISUAL_CLASS Meml[$1+13] # Class of colormap +define X_RED_MASK Meml[$1+14] # Z red mask +define X_GREEN_MASK Meml[$1+15] # Z green mask +define X_BLUE_MASK Meml[$1+16] # Z blue mask +define X_BITS_PER_RGB Meml[$1+17] # Log2 of distinct color values +define X_COLORMAP_ENTRIES Meml[$1+18] # Number of entries in colormap +define X_NCOLORS Meml[$1+19] # Number of Color structures +define X_WINDOW_WIDTH Meml[$1+20] # Window width +define X_WINDOW_HEIGHT Meml[$1+21] # Window height +define X_WINDOW_X Meml[$1+22] # Window upper left X coordinate +define X_WINDOW_Y Meml[$1+23] # Window upper left Y coordinate +define X_WINDOW_BDRWIDTH Meml[$1+24] # Window border width + +define LSBFirst 0 # Byte order flags +define MSBFirst 1 + +define XYBitmap 0 # Pixmap types +define XYPixmap 1 +define ZPixmap 2 + +define StaticGray 0 # Recognized visuals +define GrayScale 1 +define StaticColor 2 +define PseudoColor 3 +define TrueColor 4 +define DirectColor 5 + +define DEBUG false + + +# EX_XWD - Write the output image to an X11 Window Dump file. + +procedure ex_xwd (ex) + +pointer ex #i task struct pointer + +pointer xwd, cmap +char cflags, fname[SZ_FNAME] +int i, fd, flags +long pixel +short r, g, b, val + +int strlen() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + fd = EX_FD(ex) + if (EX_NEXPR(ex) != 1 && EX_NEXPR(ex) != 3 && EX_NEXPR(ex) != 4) { + if (!bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for XWD.") + } + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for XWD.") + + # Fix the output pixel type to single bytes. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Allocate space for the header. + iferr (call calloc (xwd, SZ_XWD, TY_STRUCT)) + call error (0, "Error allocate XWD structure.") + + # Set up the header values. + flags = EX_OUTFLAGS(ex) + X_HEADER_SIZE(xwd) = SZ_XWDHEADER + strlen ("xwddump") + 1 + X_FILE_VERSION(xwd) = X11WD_FILE_VERSION + X_PIXMAP_FORMAT(xwd) = ZPixmap + X_PIXMAP_WIDTH(xwd) = EX_OCOLS(ex) + X_PIXMAP_HEIGHT(xwd) = EX_OROWS(ex) + X_XOFFSET(xwd) = 0 + X_BYTE_ORDER(xwd) = MSBFirst + X_BITMAP_BIT_ORDER(xwd) = MSBFirst + X_WINDOW_WIDTH(xwd) = EX_OCOLS(ex) + X_WINDOW_HEIGHT(xwd) = EX_OROWS(ex) + X_WINDOW_X(xwd) = 0 + X_WINDOW_Y(xwd) = 0 + X_WINDOW_BDRWIDTH(xwd) = 0 + + if (EX_NEXPR(ex) >= 3) { + if (DEBUG) call eprintf ("We think this is a DirectColor image.\n") + X_PIXMAP_DEPTH(xwd) = 24 + X_BITMAP_UNIT(xwd) = 32 + X_BITMAP_PAD(xwd) = 32 + X_BITS_PER_PIXEL(xwd) = 32 + X_VISUAL_CLASS(xwd) = DirectColor + X_COLORMAP_ENTRIES(xwd) = 256 + X_NCOLORS(xwd) = 0 + X_RED_MASK(xwd) = 0FF0000X + X_GREEN_MASK(xwd) = 0FF00X + X_BLUE_MASK(xwd) = 0FFX + X_BYTES_PER_LINE(xwd) = EX_OCOLS(ex) * 4 + } else if (bitset (flags, OF_CMAP)) { + if (DEBUG) call eprintf ("We think this has a colormap.\n") + X_PIXMAP_DEPTH(xwd) = 8 + X_BITS_PER_PIXEL(xwd) = 8 + X_COLORMAP_ENTRIES(xwd) = EX_NCOLORS(ex) + X_NCOLORS(xwd) = EX_NCOLORS(ex) + X_BYTES_PER_LINE(xwd) = EX_OCOLS(ex) + + X_BITMAP_UNIT(xwd) = 8 + X_BITMAP_PAD(xwd) = 8 + X_VISUAL_CLASS(xwd) = StaticGray + X_RED_MASK(xwd) = 0 + X_GREEN_MASK(xwd) = 0 + X_BLUE_MASK(xwd) = 0 + } else { + if (DEBUG) call eprintf ("Pseudocolor.\n") + X_PIXMAP_DEPTH(xwd) = 8 + X_BITS_PER_PIXEL(xwd) = 8 + X_VISUAL_CLASS(xwd) = PseudoColor + X_COLORMAP_ENTRIES(xwd) = 255 + 1 + X_NCOLORS(xwd) = EX_NCOLORS(ex) + X_RED_MASK(xwd) = 0 + X_GREEN_MASK(xwd) = 0 + X_BLUE_MASK(xwd) = 0 + X_BYTES_PER_LINE(xwd) = EX_OCOLS(ex) + X_BITMAP_UNIT(xwd) = 8 + X_BITMAP_PAD(xwd) = 8 + } + X_BITS_PER_RGB(xwd) = X_PIXMAP_DEPTH(xwd) + + # See if we need to byte swap in order to get MSB byte ordering. + if (BYTE_SWAP4 == YES) + call bswap4 (Meml[xwd], 1, Meml[xwd], 1, SZ_XWDHEADER) + if (EX_BSWAP(ex) == S_I4) + call bswap4 (Meml[xwd], 1, Meml[xwd], 1, SZ_XWDHEADER) + call write (fd, Meml[xwd], SZ_XWDHEADER/SZB_CHAR) + call strpak ("xwddump\0", fname, 8) + call write (fd, fname, 4) + + # If we have a colormap set up the structure and write it out. + if (bitset (flags, OF_CMAP)) { + cmap = EX_CMAP(ex) + cflags = 0 + do i = 1, EX_NCOLORS(ex) { + pixel = i - 1 + r = CMAP(cmap,EX_RED,i) * 65535 / 256 + g = CMAP(cmap,EX_GREEN,i) * 65535 / 256 + b = CMAP(cmap,EX_BLUE,i) * 65535 / 256 + + call xwd_putlong (ex, fd, pixel) + call xwd_putword (ex, fd, r) + call xwd_putword (ex, fd, g) + call xwd_putword (ex, fd, b) + call xwd_putword (ex, fd, cflags) + } + } else if (EX_NEXPR(ex) < 3) { + do i = 0, 255 { + val = i * 65535 / 256 + call xwd_putlong (ex, fd, long(i)) + call xwd_putword (ex, fd, val) + call xwd_putword (ex, fd, val) + call xwd_putword (ex, fd, val) + val = 0 #shifti (7, 8) + call xwd_putword (ex, fd, val) + } + } + + # Finally, evaluate the expressions and write the image. + if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) + call ex_no_interleave (ex) + else if (EX_NEXPR(ex) == 3) { + # If all they gave were the RGB values we need to patch the + # outbands expressions to stick in an alpha channel. Patch it + # up here. + + call ex_alloc_outbands (OBANDS(ex,4)) + do i = 4, 2, -1 { + call strcpy (O_EXPR(ex,i-1), O_EXPR(ex,i), SZ_EXPSTR) + O_WIDTH(ex,i) = O_WIDTH(ex,i-1) + O_HEIGHT(ex,i) = O_HEIGHT(ex,i-1) + } + call strcpy ("0", O_EXPR(ex,1), SZ_EXPSTR) + EX_NEXPR(ex) = 4 + call ex_px_interleave (ex) + + } else if (EX_NEXPR(ex) >= 3) + call ex_px_interleave (ex) + + # Clean up. + call mfree (xwd, TY_STRUCT) +end + + +# XWD_PUTWORD - Writes a 16-bit integer in XWD order (MSB first). + +procedure xwd_putword (ex, fd, w) + +pointer ex #i task struct pointer +int fd +short w + +short val + +begin + # If this is a MSB-first machine swap the bytes before output. + if (BYTE_SWAP2 == YES) + call bswap2 (w, 1, val, 1, (SZ_SHORT * SZB_CHAR)) + else + val = w + if (EX_BSWAP(ex) == S_I2) + call bswap2 (val, 1, val, 1, (SZ_SHORT * SZB_CHAR)) + + call write (fd, val, SZ_SHORT/SZ_CHAR) +end + + +# XWD_PUTLONG - Writes a 32-bit integer in XWD order (MSB first). + +procedure xwd_putlong (ex, fd, w) + +pointer ex #i task struct pointer +int fd +long w + +long val + +begin + # If this is a MSB-first machine swap the bytes before output. + if (BYTE_SWAP4 == YES) + call bswap4 (w, 1, val, 1, (SZ_LONG * SZB_CHAR)) + else + val = w + if (EX_BSWAP(ex) == S_I4) + call bswap4 (val, 1, val, 1, (SZ_LONG * SZB_CHAR)) + + call write (fd, val, SZ_LONG/SZ_CHAR) +end diff --git a/pkg/dataio/export/bltins/mkpkg b/pkg/dataio/export/bltins/mkpkg new file mode 100644 index 00000000..14e6b8d4 --- /dev/null +++ b/pkg/dataio/export/bltins/mkpkg @@ -0,0 +1,20 @@ +# Mkpkg file for building the EXPORT task builtin formats. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + exeps.x ../exbltins.h ../export.h \ + + exgif.x ../exbltins.h ../export.h + exiraf.x ../export.h + exmiff.x ../export.h + expgm.x ../export.h + exppm.x ../export.h + exras.x ../export.h + exrgb.x ../exbltins.h ../export.h + exvicar.x ../export.h + exxwd.x ../exbltins.h ../export.h + ; diff --git a/pkg/dataio/export/cmaps.inc b/pkg/dataio/export/cmaps.inc new file mode 100644 index 00000000..91707e68 --- /dev/null +++ b/pkg/dataio/export/cmaps.inc @@ -0,0 +1,534 @@ +short aips0[768] +data (aips0(i),i= 1, 12) / 0, 0, 0, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 13, 24) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 25, 36) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 37, 48) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 49, 60) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 61, 72) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 73, 84) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 85, 96) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 97,108) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=109,120) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=121,132) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=133,144) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=145,156) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=157,168) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=169,180) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=181,192) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=193,204) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=205,216) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=217,228) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=229,240) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=241,252) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=253,264) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=265,276) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=277,288) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=289,300) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=301,312) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=313,324) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=325,336) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=337,348) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=349,360) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=361,372) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=373,384) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=385,396) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=397,408) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=409,420) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=421,432) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=433,444) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=445,456) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=457,468) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=469,480) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=481,492) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=493,504) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=505,516) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=517,528) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=529,540) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=541,552) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=553,564) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=565,576) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=577,588) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=589,600) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=601,612) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=613,624) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=625,636) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=637,648) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=649,660) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=661,672) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=673,684) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=685,696) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=697,708) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=709,720) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=721,732) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=733,744) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=745,756) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=757,768) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ + + +short color[768] +data (color(i),i= 1, 12) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (color(i),i= 13, 24) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (color(i),i= 25, 36) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (color(i),i= 37, 48) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (color(i),i= 49, 60) / 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46/ +data (color(i),i= 61, 72) / 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46/ +data (color(i),i= 73, 84) / 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46/ +data (color(i),i= 85, 96) / 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46/ +data (color(i),i= 97,108) / 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95/ +data (color(i),i=109,120) / 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95/ +data (color(i),i=121,132) / 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95/ +data (color(i),i=133,144) / 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95/ +data (color(i),i=145,156) /142,142,142,142,142,142,142,142,142,142,142,142/ +data (color(i),i=157,168) /142,142,142,142,142,142,142,142,142,142,142,142/ +data (color(i),i=169,180) /142,142,142,142,142,142,142,142,142,142,142,142/ +data (color(i),i=181,192) /142,142,142,142,142,142,142,142,142,142,142,142/ +data (color(i),i=193,204) /191,191,191,191,191,191,191,191,191,191,191,191/ +data (color(i),i=205,216) /191,191,191,191,191,191,191,191,191,191,191,191/ +data (color(i),i=217,228) /191,191,191,191,191,191,191,191,191,191,191,191/ +data (color(i),i=229,240) /191,191,191,191,191,191,191,191,191,191,191,191/ +data (color(i),i=241,252) /238,238,238,238,238,238,238,238,238,238,238,238/ +data (color(i),i=253,264) /238,238,238,238,238,238,238,238,238,238,238,238/ +data (color(i),i=265,276) /238,238,238,238,238,238,238,238,238,238,238,238/ +data (color(i),i=277,288) /238,238,238,238,238,238,238,238,238,238,238,238/ +data (color(i),i=289,300) / 0, 46,238, 0, 46,238, 0, 46,238, 0, 46,238/ +data (color(i),i=301,312) / 0, 46,238, 0, 46,238, 0, 46,238, 0, 46,238/ +data (color(i),i=313,324) / 0, 46,238, 0, 46,238, 0, 46,238, 0, 46,238/ +data (color(i),i=325,336) / 0, 46,238, 0, 46,238, 0, 46,238, 0, 46,238/ +data (color(i),i=337,348) / 0, 95,191, 0, 95,191, 0, 95,191, 0, 95,191/ +data (color(i),i=349,360) / 0, 95,191, 0, 95,191, 0, 95,191, 0, 95,191/ +data (color(i),i=361,372) / 0, 95,191, 0, 95,191, 0, 95,191, 0, 95,191/ +data (color(i),i=373,384) / 0, 95,191, 0, 95,191, 0, 95,191, 0, 95,191/ +data (color(i),i=385,396) / 0,127,127, 0,127,127, 0,127,127, 0,127,127/ +data (color(i),i=397,408) / 0,127,127, 0,127,127, 0,127,127, 0,127,127/ +data (color(i),i=409,420) / 0,127,127, 0,127,127, 0,127,127, 0,127,127/ +data (color(i),i=421,432) / 0,127,127, 0,127,127, 0,127,127, 0,127,127/ +data (color(i),i=433,444) / 0,191, 78, 0,191, 78, 0,191, 78, 0,191, 78/ +data (color(i),i=445,456) / 0,191, 78, 0,191, 78, 0,191, 78, 0,191, 78/ +data (color(i),i=457,468) / 0,191, 78, 0,191, 78, 0,191, 78, 0,191, 78/ +data (color(i),i=469,480) / 0,191, 78, 0,191, 78, 0,191, 78, 0,191, 78/ +data (color(i),i=481,492) / 0,238, 0, 0,238, 0, 0,238, 0, 0,238, 0/ +data (color(i),i=493,504) / 0,238, 0, 0,238, 0, 0,238, 0, 0,238, 0/ +data (color(i),i=505,516) / 0,238, 0, 0,238, 0, 0,238, 0, 0,238, 0/ +data (color(i),i=517,528) / 0,238, 0, 0,238, 0, 0,238, 0, 0,238, 0/ +data (color(i),i=529,540) / 78,159, 0, 78,159, 0, 78,159, 0, 78,159, 0/ +data (color(i),i=541,552) / 78,159, 0, 78,159, 0, 78,159, 0, 78,159, 0/ +data (color(i),i=553,564) / 78,159, 0, 78,159, 0, 78,159, 0, 78,159, 0/ +data (color(i),i=565,576) / 78,159, 0, 78,159, 0, 78,159, 0, 78,159, 0/ +data (color(i),i=577,588) /127,127, 0,127,127, 0,127,127, 0,127,127, 0/ +data (color(i),i=589,600) /127,127, 0,127,127, 0,127,127, 0,127,127, 0/ +data (color(i),i=601,612) /127,127, 0,127,127, 0,127,127, 0,127,127, 0/ +data (color(i),i=613,624) /127,127, 0,127,127, 0,127,127, 0,127,127, 0/ +data (color(i),i=625,636) /159, 78, 0,159, 78, 0,159, 78, 0,159, 78, 0/ +data (color(i),i=637,648) /159, 78, 0,159, 78, 0,159, 78, 0,159, 78, 0/ +data (color(i),i=649,660) /159, 78, 0,159, 78, 0,159, 78, 0,159, 78, 0/ +data (color(i),i=661,672) /159, 78, 0,159, 78, 0,159, 78, 0,159, 78, 0/ +data (color(i),i=673,684) /238, 0, 0,238, 0, 0,238, 0, 0,238, 0, 0/ +data (color(i),i=685,696) /238, 0, 0,238, 0, 0,238, 0, 0,238, 0, 0/ +data (color(i),i=697,708) /238, 0, 0,238, 0, 0,238, 0, 0,238, 0, 0/ +data (color(i),i=709,720) /238, 0, 0,238, 0, 0,238, 0, 0,238, 0, 0/ +data (color(i),i=721,732) /191, 0, 78,191, 0, 78,191, 0, 78,191, 0, 78/ +data (color(i),i=733,744) /191, 0, 78,191, 0, 78,191, 0, 78,191, 0, 78/ +data (color(i),i=745,756) /191, 0, 78,191, 0, 78,191, 0, 78,191, 0, 78/ +data (color(i),i=757,768) /191, 0, 78,191, 0, 78,191, 0, 78,191, 0, 78/ + + +short halley[768] +data (halley(i),i= 1, 12) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,179/ +data (halley(i),i= 13, 24) / 0, 0,179, 0, 0,220, 0, 0,220,120, 0,220/ +data (halley(i),i= 25, 36) /120, 0,220,120, 0,220,179, 0,229,179, 0,229/ +data (halley(i),i= 37, 48) /255, 0,255,255, 0,255,255, 0,179,255, 0,179/ +data (halley(i),i= 49, 60) /255, 0,132,255, 0, 0,255, 0, 0,255,120, 0/ +data (halley(i),i= 61, 72) /255,120, 0,252,184, 0,252,184, 0,250,206, 0/ +data (halley(i),i= 73, 84) /250,216, 0,250,216, 0,255,255, 0,255,255, 0/ +data (halley(i),i= 85, 96) /179,255, 0,179,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i= 97,108) / 0,255, 0, 0,255,179, 0,255,179, 0,255,255/ +data (halley(i),i=109,120) / 0,255,255,120,199,255,120,199,255,120,199,255/ +data (halley(i),i=121,132) /159,159,255,159,159,255,199,120,255,199,120,255/ +data (halley(i),i=133,144) /255,179,255,255,179,255,255,196,255,255,220,255/ +data (halley(i),i=145,156) /255,220,255,255,255,255,255,255,255,255,255,255/ +data (halley(i),i=157,168) /255,255,255,255,229,255,255,220,255,255,220,255/ +data (halley(i),i=169,180) /255,220,255, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=181,192) / 0,255, 0, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=193,204) / 0,255, 0, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=205,216) / 0,255, 0, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=217,228) /235,158,255,199,120,255,199,120,255,199,120,255/ +data (halley(i),i=229,240) /199,120,255,199,120,255,199,120,255,199,120,255/ +data (halley(i),i=241,252) /199,120,255,199,120,255,167,152,255,159,159,255/ +data (halley(i),i=253,264) /159,159,255, 0, 0,255, 0, 0,255, 0, 0,255/ +data (halley(i),i=265,276) / 0, 0,255, 0, 0,255, 0, 0,255, 0, 0,255/ +data (halley(i),i=277,288) / 0, 0,255, 0, 0,255,255, 0, 0,255, 0, 0/ +data (halley(i),i=289,300) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=301,312) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=313,324) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=325,336) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=337,348) /255, 0, 0,255, 0, 0, 0,255,179, 0,255,179/ +data (halley(i),i=349,360) / 0,255,179, 0,255,179, 0,255,179, 0,255,179/ +data (halley(i),i=361,372) / 0,255,166, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=373,384) / 0,255, 0, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=385,396) / 0,255, 0, 0,255, 0, 91,255, 0,179,255, 0/ +data (halley(i),i=397,408) /179,255, 0,179,255, 0,179,255, 0,179,255, 0/ +data (halley(i),i=409,420) /179,255, 0,179,255, 0,179,255, 0,179,255, 0/ +data (halley(i),i=421,432) /250,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (halley(i),i=433,444) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (halley(i),i=445,456) /255,255, 0,254,248, 0,250,216, 0,250,216, 0/ +data (halley(i),i=457,468) /250,216, 0,250,216, 0,250,216, 0,250,216, 0/ +data (halley(i),i=469,480) /250,216, 0,250,216, 0,250,216, 0,252,197, 0/ +data (halley(i),i=481,492) /252,184, 0,252,184, 0,252,184, 0,252,184, 0/ +data (halley(i),i=493,504) /252,184, 0,252,184, 0,252,184, 0,252,184, 0/ +data (halley(i),i=505,516) /252,184, 0,255,120, 0,255,120, 0,255,120, 0/ +data (halley(i),i=517,528) /255,120, 0,255,120, 0,255,120, 0,255,120, 0/ +data (halley(i),i=529,540) /255,120, 0,255,120, 0,255, 94, 0,255, 0, 0/ +data (halley(i),i=541,552) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=553,564) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=565,576) /255, 0,119,255, 0,179,255, 0,179,255, 0,179/ +data (halley(i),i=577,588) /255, 0,179,255, 0,179,255, 0,179,255, 0,179/ +data (halley(i),i=589,600) /255, 0,179,255, 0,179,255, 0,255,255, 0,255/ +data (halley(i),i=601,612) /255, 0,255,255, 0,255,255, 0,255,255, 0,255/ +data (halley(i),i=613,624) /255, 0,255,255, 0,255,255, 0,255,233, 0,248/ +data (halley(i),i=625,636) /179, 0,229,179, 0,229,179, 0,229,179, 0,229/ +data (halley(i),i=637,648) /179, 0,229,179, 0,229,179, 0,229,179, 0,229/ +data (halley(i),i=649,660) /179, 0,229,135, 0,223,120, 0,220,120, 0,220/ +data (halley(i),i=661,672) /120, 0,220,120, 0,220,120, 0,220,120, 0,220/ +data (halley(i),i=673,684) /120, 0,220,120, 0,220,120, 0,220,255,255,255/ +data (halley(i),i=685,696) /255,255,255,255,255,255,255,255,255,255,255,255/ +data (halley(i),i=697,708) / 0, 0,220, 0, 0,220, 0, 0,220, 0, 0,220/ +data (halley(i),i=709,720) / 0, 0,204, 0, 0,179, 0, 0,179, 0, 0,179/ +data (halley(i),i=721,732) / 0, 0,179, 0, 0,179, 0, 0,179, 0, 0,179/ +data (halley(i),i=733,744) / 0, 0,179, 0, 0,179, 0, 0, 34, 0, 0, 0/ +data (halley(i),i=745,756) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (halley(i),i=757,768) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ + + +short heat[768] +data (heat(i),i= 1, 12) / 0, 0, 0, 2, 0, 0, 6, 1, 0, 8, 2, 0/ +data (heat(i),i= 13, 24) / 12, 4, 0, 14, 5, 0, 18, 6, 0, 20, 6, 0/ +data (heat(i),i= 25, 36) / 24, 7, 0, 26, 8, 0, 30, 10, 0, 32, 11, 0/ +data (heat(i),i= 37, 48) / 36, 12, 0, 38, 12, 0, 42, 13, 0, 44, 14, 0/ +data (heat(i),i= 49, 60) / 48, 16, 0, 51, 17, 0, 53, 18, 0, 57, 19, 0/ +data (heat(i),i= 61, 72) / 59, 19, 0, 63, 20, 0, 65, 21, 0, 69, 23, 0/ +data (heat(i),i= 73, 84) / 71, 24, 0, 75, 25, 0, 77, 25, 0, 81, 26, 0/ +data (heat(i),i= 85, 96) / 83, 27, 0, 87, 29, 0, 89, 30, 0, 93, 31, 0/ +data (heat(i),i= 97,108) / 95, 31, 0, 99, 32, 0,102, 33, 0,104, 34, 0/ +data (heat(i),i=109,120) /108, 36, 0,110, 37, 0,114, 38, 0,116, 38, 0/ +data (heat(i),i=121,132) /120, 39, 0,122, 40, 0,126, 42, 0,128, 43, 0/ +data (heat(i),i=133,144) /132, 44, 0,134, 44, 0,138, 45, 0,140, 46, 0/ +data (heat(i),i=145,156) /144, 48, 0,146, 49, 0,150, 50, 0,153, 51, 0/ +data (heat(i),i=157,168) /155, 51, 0,159, 52, 0,161, 53, 0,165, 55, 0/ +data (heat(i),i=169,180) /167, 56, 0,171, 57, 0,173, 57, 0,177, 58, 0/ +data (heat(i),i=181,192) /179, 59, 0,183, 61, 0,185, 62, 0,189, 63, 0/ +data (heat(i),i=193,204) /191, 63, 0,195, 64, 0,197, 65, 0,201, 67, 0/ +data (heat(i),i=205,216) /204, 68, 0,206, 69, 0,210, 70, 0,212, 70, 0/ +data (heat(i),i=217,228) /216, 71, 0,218, 72, 0,222, 74, 0,224, 75, 0/ +data (heat(i),i=229,240) /228, 76, 0,230, 76, 0,234, 77, 0,236, 78, 0/ +data (heat(i),i=241,252) /240, 80, 0,242, 81, 0,246, 82, 0,248, 82, 0/ +data (heat(i),i=253,264) /252, 83, 0,255, 84, 0,255, 85, 0,255, 87, 0/ +data (heat(i),i=265,276) /255, 88, 0,255, 89, 0,255, 89, 0,255, 90, 0/ +data (heat(i),i=277,288) /255, 91, 0,255, 93, 0,255, 94, 0,255, 95, 0/ +data (heat(i),i=289,300) /255, 95, 0,255, 96, 0,255, 97, 0,255, 99, 0/ +data (heat(i),i=301,312) /255,100, 0,255,101, 0,255,102, 0,255,102, 0/ +data (heat(i),i=313,324) /255,103, 0,255,104, 0,255,106, 0,255,107, 0/ +data (heat(i),i=325,336) /255,108, 0,255,108, 0,255,109, 0,255,110, 0/ +data (heat(i),i=337,348) /255,112, 0,255,113, 0,255,114, 0,255,114, 0/ +data (heat(i),i=349,360) /255,115, 0,255,116, 0,255,118, 0,255,119, 0/ +data (heat(i),i=361,372) /255,120, 0,255,121, 0,255,121, 0,255,122, 0/ +data (heat(i),i=373,384) /255,123, 0,255,125, 0,255,126, 0,255,127, 0/ +data (heat(i),i=385,396) /255,127, 0,255,128, 0,255,129, 0,255,131, 0/ +data (heat(i),i=397,408) /255,132, 0,255,133, 0,255,133, 0,255,134, 0/ +data (heat(i),i=409,420) /255,135, 0,255,136, 0,255,138, 0,255,139, 0/ +data (heat(i),i=421,432) /255,140, 0,255,140, 0,255,141, 0,255,142, 0/ +data (heat(i),i=433,444) /255,144, 0,255,145, 0,255,146, 0,255,146, 0/ +data (heat(i),i=445,456) /255,147, 0,255,148, 0,255,150, 0,255,151, 0/ +data (heat(i),i=457,468) /255,152, 0,255,153, 0,255,153, 0,255,154, 0/ +data (heat(i),i=469,480) /255,155, 0,255,157, 0,255,158, 0,255,159, 0/ +data (heat(i),i=481,492) /255,159, 0,255,160, 0,255,161, 0,255,163, 0/ +data (heat(i),i=493,504) /255,164, 0,255,165, 0,255,165, 2,255,166, 6/ +data (heat(i),i=505,516) /255,167, 8,255,169, 12,255,170, 14,255,171, 18/ +data (heat(i),i=517,528) /255,172, 20,255,172, 24,255,173, 26,255,174, 30/ +data (heat(i),i=529,540) /255,176, 32,255,177, 36,255,178, 38,255,178, 42/ +data (heat(i),i=541,552) /255,179, 44,255,180, 48,255,182, 51,255,183, 53/ +data (heat(i),i=553,564) /255,184, 57,255,184, 59,255,185, 63,255,186, 65/ +data (heat(i),i=565,576) /255,187, 69,255,189, 71,255,190, 75,255,191, 77/ +data (heat(i),i=577,588) /255,191, 81,255,192, 83,255,193, 87,255,195, 89/ +data (heat(i),i=589,600) /255,196, 93,255,197, 95,255,197, 99,255,198,102/ +data (heat(i),i=601,612) /255,199,104,255,201,108,255,202,110,255,203,114/ +data (heat(i),i=613,624) /255,204,116,255,204,120,255,205,122,255,206,126/ +data (heat(i),i=625,636) /255,208,128,255,209,132,255,210,134,255,210,138/ +data (heat(i),i=637,648) /255,211,140,255,212,144,255,214,146,255,215,150/ +data (heat(i),i=649,660) /255,216,153,255,216,155,255,217,159,255,218,161/ +data (heat(i),i=661,672) /255,220,165,255,221,167,255,222,171,255,223,173/ +data (heat(i),i=673,684) /255,223,177,255,224,179,255,225,183,255,227,185/ +data (heat(i),i=685,696) /255,228,189,255,229,191,255,229,195,255,230,197/ +data (heat(i),i=697,708) /255,231,201,255,233,204,255,234,206,255,235,210/ +data (heat(i),i=709,720) /255,235,212,255,236,216,255,237,218,255,238,222/ +data (heat(i),i=721,732) /255,240,224,255,241,228,255,242,230,255,242,234/ +data (heat(i),i=733,744) /255,243,236,255,244,240,255,246,242,255,247,246/ +data (heat(i),i=745,756) /255,248,248,255,248,252,255,249,255,255,250,255/ +data (heat(i),i=757,768) /255,252,255,255,253,255,255,254,255,255,255,255/ + + +short rainbow[768] +data (rainbow(i),i= 1, 12) / 0, 0, 42, 6, 0, 46, 14, 0, 51, 21, 0, 56/ +data (rainbow(i),i= 13, 24) / 29, 0, 61, 37, 0, 65, 44, 0, 70, 51, 0, 76/ +data (rainbow(i),i= 25, 36) / 58, 0, 81, 67, 0, 85, 75, 0, 90, 82, 0, 95/ +data (rainbow(i),i= 37, 48) / 89, 0,101, 96, 0,106,104, 0,110,112, 0,115/ +data (rainbow(i),i= 49, 60) /120, 0,121,127, 0,126,134, 0,131,141, 0,136/ +data (rainbow(i),i= 61, 72) /150, 0,141,141, 0,146,134, 0,152,127, 0,157/ +data (rainbow(i),i= 73, 84) /120, 0,163,112, 0,167,104, 0,172, 96, 0,178/ +data (rainbow(i),i= 85, 96) / 89, 0,184, 82, 0,189, 75, 0,195, 67, 0,199/ +data (rainbow(i),i= 97,108) / 58, 0,204, 51, 0,210, 44, 0,216, 37, 0,222/ +data (rainbow(i),i=109,120) / 29, 0,227, 21, 0,233, 14, 0,237, 6, 0,243/ +data (rainbow(i),i=121,132) / 0, 0,248, 0, 0,255, 0, 6,248, 0, 12,243/ +data (rainbow(i),i=133,144) / 0, 16,237, 0, 20,233, 0, 25,227, 0, 29,222/ +data (rainbow(i),i=145,156) / 0, 32,216, 0, 36,210, 0, 39,204, 0, 43,199/ +data (rainbow(i),i=157,168) / 0, 46,195, 0, 50,189, 0, 53,184, 0, 57,178/ +data (rainbow(i),i=169,180) / 0, 59,172, 0, 63,167, 0, 67,163, 0, 70,157/ +data (rainbow(i),i=181,192) / 0, 72,152, 0, 76,146, 0, 78,141, 0, 82,136/ +data (rainbow(i),i=193,204) / 0, 84,131, 0, 88,126, 0, 90,121, 0, 94,115/ +data (rainbow(i),i=205,216) / 0, 96,110, 0,100,106, 0,102,101, 0,104, 95/ +data (rainbow(i),i=217,228) / 0,108, 90, 0,110, 85, 0,114, 81, 0,116, 76/ +data (rainbow(i),i=229,240) / 0,119, 70, 0,121, 65, 0,125, 61, 0,127, 56/ +data (rainbow(i),i=241,252) / 0,129, 51, 0,133, 46, 0,134, 42, 0,138, 37/ +data (rainbow(i),i=253,264) / 0,140, 32, 0,142, 27, 0,146, 24, 0,148, 19/ +data (rainbow(i),i=265,276) / 0,151, 14, 0,153, 11, 0,155, 6, 0,159, 2/ +data (rainbow(i),i=277,288) / 0,160, 0, 0,164, 0, 0,165, 0, 0,169, 0/ +data (rainbow(i),i=289,300) / 0,171, 0, 0,173, 0, 0,176, 0, 0,178, 0/ +data (rainbow(i),i=301,312) / 0,180, 0, 0,184, 0, 0,185, 0, 0,189, 0/ +data (rainbow(i),i=313,324) / 0,191, 0, 0,193, 0, 0,196, 0, 0,197, 0/ +data (rainbow(i),i=325,336) / 0,201, 0, 0,203, 0, 0,205, 0, 0,208, 0/ +data (rainbow(i),i=337,348) / 0,210, 0, 0,212, 0, 0,215, 0, 0,217, 0/ +data (rainbow(i),i=349,360) / 0,220, 0, 0,222, 0, 0,224, 0, 0,227, 0/ +data (rainbow(i),i=361,372) / 0,229, 0, 0,231, 0, 0,234, 0, 0,235, 0/ +data (rainbow(i),i=373,384) / 0,238, 0, 0,241, 0, 0,242, 0, 0,244, 0/ +data (rainbow(i),i=385,396) / 0,248, 0, 0,249, 0, 0,252, 0, 0,255, 0/ +data (rainbow(i),i=397,408) / 0,252, 0, 0,249, 0, 0,248, 0, 0,244, 0/ +data (rainbow(i),i=409,420) / 0,242, 0, 0,241, 0, 0,238, 0, 0,235, 0/ +data (rainbow(i),i=421,432) / 0,234, 0, 0,231, 0, 0,229, 0, 0,227, 0/ +data (rainbow(i),i=433,444) / 0,224, 0, 0,222, 0, 0,220, 0, 0,217, 0/ +data (rainbow(i),i=445,456) / 0,215, 0, 0,212, 0, 0,210, 0, 0,208, 0/ +data (rainbow(i),i=457,468) / 0,205, 0, 0,203, 0, 0,201, 0, 0,197, 0/ +data (rainbow(i),i=469,480) / 1,196, 0, 8,197, 0, 17,201, 0, 25,204, 0/ +data (rainbow(i),i=481,492) / 32,206, 0, 42,210, 0, 51,215, 0, 59,218, 0/ +data (rainbow(i),i=493,504) / 68,222, 0, 77,227, 0, 87,229, 0, 95,235, 0/ +data (rainbow(i),i=505,516) /104,237, 0,114,242, 0,123,247, 0,133,252, 0/ +data (rainbow(i),i=517,528) /142,255, 0,152,255, 0,161,255, 0,171,255, 0/ +data (rainbow(i),i=529,540) /180,255, 0,191,255, 0,199,255, 0,210,255, 0/ +data (rainbow(i),i=541,552) /218,255, 0,229,255, 0,237,255, 0,248,255, 0/ +data (rainbow(i),i=553,564) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (rainbow(i),i=565,576) /255,255, 0,255,255, 0,255,255, 0,254,255, 0/ +data (rainbow(i),i=577,588) /249,255, 0,244,248, 0,241,238, 0,235,229, 0/ +data (rainbow(i),i=589,600) /231,218, 0,228,209, 0,223,198, 0,218,189, 0/ +data (rainbow(i),i=601,612) /214,178, 0,210,169, 0,204,159, 0,201,148, 0/ +data (rainbow(i),i=613,624) /196,139, 0,192,129, 0,189,119, 0,184,109, 0/ +data (rainbow(i),i=625,636) /180,100, 0,177, 89, 0,173, 81, 0,169, 70, 0/ +data (rainbow(i),i=637,648) /165, 61, 0,161, 51, 0,159, 43, 0,157, 32, 0/ +data (rainbow(i),i=649,660) /154, 25, 0,158, 20, 0,159, 16, 0,163, 12, 0/ +data (rainbow(i),i=661,672) /165, 6, 0,167, 0, 0,170, 0, 0,172, 0, 0/ +data (rainbow(i),i=673,684) /174, 0, 0,178, 0, 0,180, 0, 0,183, 0, 0/ +data (rainbow(i),i=685,696) /185, 0, 0,187, 0, 0,191, 0, 0,192, 0, 0/ +data (rainbow(i),i=697,708) /196, 0, 0,197, 0, 0,201, 0, 0,204, 1, 1/ +data (rainbow(i),i=709,720) /205, 6, 6,209, 12, 12,210, 20, 20,214, 29, 29/ +data (rainbow(i),i=721,732) /216, 38, 38,218, 49, 49,221, 58, 58,223, 70, 70/ +data (rainbow(i),i=733,744) /225, 82, 82,229, 95, 95,231,109,109,234,123,123/ +data (rainbow(i),i=745,756) /236,138,138,238,153,153,242,169,169,243,184,184/ +data (rainbow(i),i=757,768) /247,202,202,248,218,218,252,236,236,255,255,255/ + + +short staircase[768] +data (staircase(i),i= 1, 12) / 0, 0, 80, 1, 1, 80, 2, 2, 80, 4, 4, 80/ +data (staircase(i),i= 13, 24) / 5, 5, 80, 6, 6, 80, 6, 6, 80, 7, 7, 80/ +data (staircase(i),i= 25, 36) / 8, 8, 80, 10, 10, 80, 11, 11, 80, 12, 12, 80/ +data (staircase(i),i= 37, 48) / 12, 12, 80, 13, 13, 80, 14, 14, 80, 16, 16, 80/ +data (staircase(i),i= 49, 60) / 17, 17,120, 18, 18,120, 19, 19,120, 19, 19,120/ +data (staircase(i),i= 61, 72) / 20, 20,120, 21, 21,120, 23, 23,120, 24, 24,120/ +data (staircase(i),i= 73, 84) / 25, 25,120, 25, 25,120, 26, 26,120, 27, 27,120/ +data (staircase(i),i= 85, 96) / 29, 29,120, 30, 30,120, 31, 31,120, 31, 31,120/ +data (staircase(i),i= 97,108) / 32, 32,159, 33, 33,159, 34, 34,159, 36, 36,159/ +data (staircase(i),i=109,120) / 37, 37,159, 38, 38,159, 38, 38,159, 39, 39,159/ +data (staircase(i),i=121,132) / 40, 40,159, 42, 42,159, 43, 43,159, 44, 44,159/ +data (staircase(i),i=133,144) / 44, 44,159, 45, 45,159, 46, 46,159, 48, 48,159/ +data (staircase(i),i=145,156) / 49, 49,199, 50, 50,199, 51, 51,199, 51, 51,199/ +data (staircase(i),i=157,168) / 52, 52,199, 53, 53,199, 55, 55,199, 56, 56,199/ +data (staircase(i),i=169,180) / 57, 57,199, 57, 57,199, 58, 58,199, 59, 59,199/ +data (staircase(i),i=181,192) / 61, 61,199, 62, 62,199, 63, 63,199, 63, 63,199/ +data (staircase(i),i=193,204) / 64, 64,240, 65, 65,240, 67, 67,240, 68, 68,240/ +data (staircase(i),i=205,216) / 69, 69,240, 70, 70,240, 70, 70,240, 71, 71,240/ +data (staircase(i),i=217,228) / 72, 72,240, 74, 74,240, 75, 75,240, 76, 76,240/ +data (staircase(i),i=229,240) / 76, 76,240, 77, 77,240, 78, 78,240, 80, 80,240/ +data (staircase(i),i=241,252) / 81, 81,242, 82, 82,246, 82, 82,248, 83, 83,252/ +data (staircase(i),i=253,264) / 84, 84,255, 0, 80, 0, 1, 80, 1, 2, 80, 2/ +data (staircase(i),i=265,276) / 4, 80, 4, 5, 80, 5, 6, 80, 6, 6, 80, 6/ +data (staircase(i),i=277,288) / 7, 80, 7, 8, 80, 8, 10, 80, 10, 11, 80, 11/ +data (staircase(i),i=289,300) / 12, 80, 12, 12, 80, 12, 13, 80, 13, 14, 80, 14/ +data (staircase(i),i=301,312) / 16, 80, 16, 17,120, 17, 18,120, 18, 19,120, 19/ +data (staircase(i),i=313,324) / 19,120, 19, 20,120, 20, 21,120, 21, 23,120, 23/ +data (staircase(i),i=325,336) / 24,120, 24, 25,120, 25, 25,120, 25, 26,120, 26/ +data (staircase(i),i=337,348) / 27,120, 27, 29,120, 29, 30,120, 30, 31,120, 31/ +data (staircase(i),i=349,360) / 31,120, 31, 32,159, 32, 33,159, 33, 34,159, 34/ +data (staircase(i),i=361,372) / 36,159, 36, 37,159, 37, 38,159, 38, 38,159, 38/ +data (staircase(i),i=373,384) / 39,159, 39, 40,159, 40, 42,159, 42, 43,159, 43/ +data (staircase(i),i=385,396) / 44,159, 44, 44,159, 44, 45,159, 45, 46,159, 46/ +data (staircase(i),i=397,408) / 48,159, 48, 49,199, 49, 50,199, 50, 51,199, 51/ +data (staircase(i),i=409,420) / 51,199, 51, 52,199, 52, 53,199, 53, 55,199, 55/ +data (staircase(i),i=421,432) / 56,199, 56, 57,199, 57, 57,199, 57, 58,199, 58/ +data (staircase(i),i=433,444) / 59,199, 59, 61,199, 61, 62,199, 62, 63,199, 63/ +data (staircase(i),i=445,456) / 63,199, 63, 64,240, 64, 65,240, 65, 67,240, 67/ +data (staircase(i),i=457,468) / 68,240, 68, 69,240, 69, 70,240, 70, 70,240, 70/ +data (staircase(i),i=469,480) / 71,240, 71, 72,240, 72, 74,240, 74, 75,240, 75/ +data (staircase(i),i=481,492) / 76,240, 76, 76,240, 76, 77,240, 77, 78,240, 78/ +data (staircase(i),i=493,504) / 80,240, 80, 81,242, 81, 82,246, 82, 82,248, 82/ +data (staircase(i),i=505,516) / 83,252, 83, 84,255, 84, 80, 0, 0, 80, 1, 1/ +data (staircase(i),i=517,528) / 80, 2, 2, 80, 4, 4, 80, 5, 5, 80, 6, 6/ +data (staircase(i),i=529,540) / 80, 6, 6, 80, 7, 7, 80, 8, 8, 80, 10, 10/ +data (staircase(i),i=541,552) / 80, 11, 11, 80, 12, 12, 80, 12, 12, 80, 13, 13/ +data (staircase(i),i=553,564) / 80, 14, 14, 80, 16, 16,120, 17, 17,120, 18, 18/ +data (staircase(i),i=565,576) /120, 19, 19,120, 19, 19,120, 20, 20,120, 21, 21/ +data (staircase(i),i=577,588) /120, 23, 23,120, 24, 24,120, 25, 25,120, 25, 25/ +data (staircase(i),i=589,600) /120, 26, 26,120, 27, 27,120, 29, 29,120, 30, 30/ +data (staircase(i),i=601,612) /120, 31, 31,120, 31, 31,159, 32, 32,159, 33, 33/ +data (staircase(i),i=613,624) /159, 34, 34,159, 36, 36,159, 37, 37,159, 38, 38/ +data (staircase(i),i=625,636) /159, 38, 38,159, 39, 39,159, 40, 40,159, 42, 42/ +data (staircase(i),i=637,648) /159, 43, 43,159, 44, 44,159, 44, 44,159, 45, 45/ +data (staircase(i),i=649,660) /159, 46, 46,159, 48, 48,199, 49, 49,199, 50, 50/ +data (staircase(i),i=661,672) /199, 51, 51,199, 51, 51,199, 52, 52,199, 53, 53/ +data (staircase(i),i=673,684) /199, 55, 55,199, 56, 56,199, 57, 57,199, 57, 57/ +data (staircase(i),i=685,696) /199, 58, 58,199, 59, 59,199, 61, 61,199, 62, 62/ +data (staircase(i),i=697,708) /199, 63, 63,199, 63, 63,240, 64, 64,240, 65, 65/ +data (staircase(i),i=709,720) /240, 67, 67,240, 68, 68,240, 69, 69,240, 70, 70/ +data (staircase(i),i=721,732) /240, 70, 70,240, 71, 71,240, 72, 72,240, 74, 74/ +data (staircase(i),i=733,744) /240, 75, 75,240, 76, 76,240, 76, 76,240, 77, 77/ +data (staircase(i),i=745,756) /240, 78, 78,240, 80, 80,242,100,100,244,134,134/ +data (staircase(i),i=757,768) /248,170,170,250,204,204,253,204,204,255,255,255/ + + +short standard[768] +data (standard(i),i= 1, 12) / 0, 0, 84, 1, 1, 87, 2, 2, 89, 4, 4, 90/ +data (standard(i),i= 13, 24) / 5, 5, 93, 6, 6, 95, 6, 6, 96, 7, 7, 99/ +data (standard(i),i= 25, 36) / 8, 8,101, 10, 10,102, 11, 11,104, 12, 12,107/ +data (standard(i),i= 37, 48) / 12, 12,108, 13, 13,110, 14, 14,113, 16, 16,114/ +data (standard(i),i= 49, 60) / 17, 17,116, 18, 18,119, 19, 19,121, 19, 19,122/ +data (standard(i),i= 61, 72) / 20, 20,125, 21, 21,127, 23, 23,128, 24, 24,131/ +data (standard(i),i= 73, 84) / 25, 25,133, 25, 25,134, 26, 26,136, 27, 27,139/ +data (standard(i),i= 85, 96) / 29, 29,140, 30, 30,142, 31, 31,145, 31, 31,146/ +data (standard(i),i= 97,108) / 32, 32,148, 33, 33,150, 34, 34,153, 36, 36,154/ +data (standard(i),i=109,120) / 37, 37,157, 38, 38,159, 38, 38,160, 39, 39,163/ +data (standard(i),i=121,132) / 40, 40,165, 42, 42,166, 43, 43,169, 44, 44,171/ +data (standard(i),i=133,144) / 44, 44,172, 45, 45,174, 46, 46,177, 48, 48,178/ +data (standard(i),i=145,156) / 49, 49,180, 50, 50,183, 51, 51,184, 51, 51,186/ +data (standard(i),i=157,168) / 52, 52,189, 53, 53,191, 55, 55,192, 56, 56,195/ +data (standard(i),i=169,180) / 57, 57,197, 57, 57,198, 58, 58,201, 59, 59,203/ +data (standard(i),i=181,192) / 61, 61,204, 62, 62,206, 63, 63,209, 63, 63,210/ +data (standard(i),i=193,204) / 64, 64,212, 65, 65,215, 67, 67,216, 68, 68,218/ +data (standard(i),i=205,216) / 69, 69,221, 70, 70,223, 70, 70,224, 71, 71,227/ +data (standard(i),i=217,228) / 72, 72,229, 74, 74,230, 75, 75,233, 76, 76,235/ +data (standard(i),i=229,240) / 76, 76,236, 77, 77,238, 78, 78,241, 80, 80,242/ +data (standard(i),i=241,252) / 81, 81,244, 82, 82,247, 82, 82,248, 83, 83,250/ +data (standard(i),i=253,264) / 84, 84,253, 0, 84, 0, 1, 87, 1, 2, 89, 2/ +data (standard(i),i=265,276) / 4, 90, 4, 5, 93, 5, 6, 95, 6, 6, 96, 6/ +data (standard(i),i=277,288) / 7, 99, 7, 8,101, 8, 10,102, 10, 11,104, 11/ +data (standard(i),i=289,300) / 12,107, 12, 12,108, 12, 13,110, 13, 14,113, 14/ +data (standard(i),i=301,312) / 16,114, 16, 17,116, 17, 18,119, 18, 19,121, 19/ +data (standard(i),i=313,324) / 19,122, 19, 20,125, 20, 21,127, 21, 23,128, 23/ +data (standard(i),i=325,336) / 24,131, 24, 25,133, 25, 25,134, 25, 26,136, 26/ +data (standard(i),i=337,348) / 27,139, 27, 29,140, 29, 30,142, 30, 31,145, 31/ +data (standard(i),i=349,360) / 31,146, 31, 32,148, 32, 33,150, 33, 34,153, 34/ +data (standard(i),i=361,372) / 36,154, 36, 37,157, 37, 38,159, 38, 38,160, 38/ +data (standard(i),i=373,384) / 39,163, 39, 40,165, 40, 42,166, 42, 43,169, 43/ +data (standard(i),i=385,396) / 44,171, 44, 44,172, 44, 45,174, 45, 46,177, 46/ +data (standard(i),i=397,408) / 48,178, 48, 49,180, 49, 50,183, 50, 51,184, 51/ +data (standard(i),i=409,420) / 51,186, 51, 52,189, 52, 53,191, 53, 55,192, 55/ +data (standard(i),i=421,432) / 56,195, 56, 57,197, 57, 57,198, 57, 58,201, 58/ +data (standard(i),i=433,444) / 59,203, 59, 61,204, 61, 62,206, 62, 63,209, 63/ +data (standard(i),i=445,456) / 63,210, 63, 64,212, 64, 65,215, 65, 67,216, 67/ +data (standard(i),i=457,468) / 68,218, 68, 69,221, 69, 70,223, 70, 70,224, 70/ +data (standard(i),i=469,480) / 71,227, 71, 72,229, 72, 74,230, 74, 75,233, 75/ +data (standard(i),i=481,492) / 76,235, 76, 76,236, 76, 77,238, 77, 78,241, 78/ +data (standard(i),i=493,504) / 80,242, 80, 81,244, 81, 82,247, 82, 82,248, 82/ +data (standard(i),i=505,516) / 83,250, 83, 84,253, 84, 84, 0, 0, 87, 1, 1/ +data (standard(i),i=517,528) / 89, 2, 2, 90, 4, 4, 93, 5, 5, 95, 6, 6/ +data (standard(i),i=529,540) / 96, 6, 6, 99, 7, 7,101, 8, 8,102, 10, 10/ +data (standard(i),i=541,552) /104, 11, 11,107, 12, 12,108, 12, 12,110, 13, 13/ +data (standard(i),i=553,564) /113, 14, 14,114, 16, 16,116, 17, 17,119, 18, 18/ +data (standard(i),i=565,576) /121, 19, 19,122, 19, 19,125, 20, 20,127, 21, 21/ +data (standard(i),i=577,588) /128, 23, 23,131, 24, 24,133, 25, 25,134, 25, 25/ +data (standard(i),i=589,600) /136, 26, 26,139, 27, 27,140, 29, 29,142, 30, 30/ +data (standard(i),i=601,612) /145, 31, 31,146, 31, 31,148, 32, 32,150, 33, 33/ +data (standard(i),i=613,624) /153, 34, 34,154, 36, 36,157, 37, 37,159, 38, 38/ +data (standard(i),i=625,636) /160, 38, 38,163, 39, 39,165, 40, 40,166, 42, 42/ +data (standard(i),i=637,648) /169, 43, 43,171, 44, 44,172, 44, 44,174, 45, 45/ +data (standard(i),i=649,660) /177, 46, 46,178, 48, 48,180, 49, 49,183, 50, 50/ +data (standard(i),i=661,672) /184, 51, 51,186, 51, 51,189, 52, 52,191, 53, 53/ +data (standard(i),i=673,684) /192, 55, 55,195, 56, 56,197, 57, 57,198, 57, 57/ +data (standard(i),i=685,696) /201, 58, 58,203, 59, 59,204, 61, 61,206, 62, 62/ +data (standard(i),i=697,708) /209, 63, 63,210, 63, 63,212, 64, 64,215, 65, 65/ +data (standard(i),i=709,720) /216, 67, 67,218, 68, 68,221, 69, 69,223, 70, 70/ +data (standard(i),i=721,732) /224, 70, 70,227, 71, 71,229, 72, 72,230, 74, 74/ +data (standard(i),i=733,744) /233, 75, 75,235, 76, 76,236, 76, 76,238, 77, 77/ +data (standard(i),i=745,756) /241, 78, 78,242, 80, 80,244, 81, 81,247, 82, 82/ +data (standard(i),i=757,768) /248, 82, 82,250, 83, 83,253, 84, 84,255, 85, 85/ + + +short overlay[768] +data (overlay(i),i= 1, 12) / 0, 0, 0, 1, 1, 1, 3, 3, 3, 4, 4, 4/ +data (overlay(i),i= 13, 24) / 5, 5, 5, 6, 6, 6, 8, 8, 8, 9, 9, 9/ +data (overlay(i),i= 25, 36) / 10, 10, 10, 11, 11, 11, 13, 13, 13, 14, 14, 14/ +data (overlay(i),i= 37, 48) / 15, 15, 15, 17, 17, 17, 18, 18, 18, 19, 19, 19/ +data (overlay(i),i= 49, 60) / 20, 20, 20, 22, 22, 22, 23, 23, 23, 24, 24, 24/ +data (overlay(i),i= 61, 72) / 26, 26, 26, 27, 27, 27, 28, 28, 28, 29, 29, 29/ +data (overlay(i),i= 73, 84) / 31, 31, 31, 32, 32, 32, 33, 33, 33, 34, 34, 34/ +data (overlay(i),i= 85, 96) / 36, 36, 36, 37, 37, 37, 38, 38, 38, 40, 40, 40/ +data (overlay(i),i= 97,108) / 41, 41, 41, 42, 42, 42, 43, 43, 43, 45, 45, 45/ +data (overlay(i),i=109,120) / 46, 46, 46, 47, 47, 47, 48, 48, 48, 50, 50, 50/ +data (overlay(i),i=121,132) / 51, 51, 51, 52, 52, 52, 54, 54, 54, 55, 55, 55/ +data (overlay(i),i=133,144) / 56, 56, 56, 57, 57, 57, 59, 59, 59, 60, 60, 60/ +data (overlay(i),i=145,156) / 61, 61, 61, 62, 62, 62, 64, 64, 64, 65, 65, 65/ +data (overlay(i),i=157,168) / 66, 66, 66, 68, 68, 68, 69, 69, 69, 70, 70, 70/ +data (overlay(i),i=169,180) / 71, 71, 71, 73, 73, 73, 74, 74, 74, 75, 75, 75/ +data (overlay(i),i=181,192) / 77, 77, 77, 78, 78, 78, 79, 79, 79, 80, 80, 80/ +data (overlay(i),i=193,204) / 82, 82, 82, 83, 83, 83, 84, 84, 84, 85, 85, 85/ +data (overlay(i),i=205,216) / 87, 87, 87, 88, 88, 88, 89, 89, 89, 91, 91, 91/ +data (overlay(i),i=217,228) / 92, 92, 92, 93, 93, 93, 94, 94, 94, 96, 96, 96/ +data (overlay(i),i=229,240) / 97, 97, 97, 98, 98, 98, 99, 99, 99,101,101,101/ +data (overlay(i),i=241,252) /102,102,102,103,103,103,105,105,105,106,106,106/ +data (overlay(i),i=253,264) /107,107,107,108,108,108,110,110,110,111,111,111/ +data (overlay(i),i=265,276) /112,112,112,113,113,113,115,115,115,116,116,116/ +data (overlay(i),i=277,288) /117,117,117,119,119,119,120,120,120,121,121,121/ +data (overlay(i),i=289,300) /122,122,122,124,124,124,125,125,125,126,126,126/ +data (overlay(i),i=301,312) /128,128,128,129,129,129,130,130,130,131,131,131/ +data (overlay(i),i=313,324) /133,133,133,134,134,134,135,135,135,136,136,136/ +data (overlay(i),i=325,336) /138,138,138,139,139,139,140,140,140,142,142,142/ +data (overlay(i),i=337,348) /143,143,143,144,144,144,145,145,145,147,147,147/ +data (overlay(i),i=349,360) /148,148,148,149,149,149,150,150,150,152,152,152/ +data (overlay(i),i=361,372) /153,153,153,154,154,154,156,156,156,157,157,157/ +data (overlay(i),i=373,384) /158,158,158,159,159,159,161,161,161,162,162,162/ +data (overlay(i),i=385,396) /163,163,163,164,164,164,166,166,166,167,167,167/ +data (overlay(i),i=397,408) /168,168,168,170,170,170,171,171,171,172,172,172/ +data (overlay(i),i=409,420) /173,173,173,175,175,175,176,176,176,177,177,177/ +data (overlay(i),i=421,432) /179,179,179,180,180,180,181,181,181,182,182,182/ +data (overlay(i),i=433,444) /184,184,184,185,185,185,186,186,186,187,187,187/ +data (overlay(i),i=445,456) /189,189,189,190,190,190,191,191,191,193,193,193/ +data (overlay(i),i=457,468) /194,194,194,195,195,195,196,196,196,198,198,198/ +data (overlay(i),i=469,480) /199,199,199,200,200,200,201,201,201,203,203,203/ +data (overlay(i),i=481,492) /204,204,204,205,205,205,207,207,207,208,208,208/ +data (overlay(i),i=493,504) /209,209,209,210,210,210,212,212,212,213,213,213/ +data (overlay(i),i=505,516) /214,214,214,215,215,215,217,217,217,218,218,218/ +data (overlay(i),i=517,528) /219,219,219,221,221,221,222,222,222,223,223,223/ +data (overlay(i),i=529,540) /224,224,224,226,226,226,227,227,227,228,228,228/ +data (overlay(i),i=541,552) /230,230,230,231,231,231,232,232,232,233,233,233/ +data (overlay(i),i=553,564) /235,235,235,236,236,236,237,237,237,238,238,238/ +data (overlay(i),i=565,576) /240,240,240,241,241,241,242,242,242,244,244,244/ +data (overlay(i),i=577,588) /245,245,245,246,246,246,247,247,247,249,249,249/ +data (overlay(i),i=589,600) /250,250,250,251,251,251,252,252,252,254,254,254/ +data (overlay(i),i=601,612) /255,255,255, 0, 0, 0,255,255,255,255, 0, 0/ +data (overlay(i),i=613,624) / 0,255, 0, 0, 0,255,255,255, 0, 0,255,255/ +data (overlay(i),i=625,636) /255, 0,255,255,127, 80,176, 48, 96,255,165, 0/ +data (overlay(i),i=637,648) /255,246,143,218,112,214, 0,245,255,238,130,238/ +data (overlay(i),i=649,660) /255,231,186, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=661,672) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=673,684) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=685,696) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=697,708) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=709,720) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=721,732) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=733,744) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=745,756) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=757,768) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ diff --git a/pkg/dataio/export/exbltins.h b/pkg/dataio/export/exbltins.h new file mode 100644 index 00000000..0723cdb2 --- /dev/null +++ b/pkg/dataio/export/exbltins.h @@ -0,0 +1,28 @@ +# EXBLTINS.H -- Macro definitions for builtin formats. + +define EX_FORMATS "|eps|epsi|epi|epsf|gif|giff|iraf|imh|miff|pgm|ppm|\ + |ps|ras|sun|sunras|rgb|sgi|irix|xwd|x11|vicar2|" + +define EPS 1 # Encapsulated PostScript +define EPSI 2 # Encapsulated PostScript (alias) +define EPI 3 # Encapsulated PostScript (alias) +define EPSF 4 # Encapsulated PostScript (alias) +define GIF 5 # Compuserve GIF format +define GIFF 6 # Compuserve GIF format (alias) +define IRAF 7 # IRAF OIF format (hidden) +define IMH 8 # IRAF OIF format (alias) +define MIFF 9 # ImageMagick MIFF format +define PGM 10 # PBMplus PGM grayscale format +define PPM 11 # PBMplus PPM color format +#newline +define PS 13 # Sun rasterfile format +define RAS 14 # Sun rasterfile format +define SUN 15 # Sun rasterfile format (alias) +define SUNRAS 16 # Sun rasterfile format (alias) +define RGB 17 # Silicon Graphics RGB format +define SGI 18 # Silicon Graphics RGB format (alias) +define IRIS 19 # Silicon Graphics RGB format (alias) +define XWD 20 # X11 Window dump +define X11 21 # X11 Window dump (alias) +define VICAR 22 # VICAR2 format + diff --git a/pkg/dataio/export/exbltins.x b/pkg/dataio/export/exbltins.x new file mode 100644 index 00000000..bb0152dd --- /dev/null +++ b/pkg/dataio/export/exbltins.x @@ -0,0 +1,243 @@ +include +include "export.h" +include "exbltins.h" + + +# EXb_BUILTIN - Process a builtin format. + +procedure exb_process_image (ex) + +pointer ex #i task struct pointer + +begin + # Branch to the appropriate procedure for processing. + switch (EX_BLTIN(ex)) { + case EPS: # Encapsulated PostScript + call ex_eps (ex) + case GIF: # GIF + call ex_gif (ex) + case IMH: # IRAF OIF + call ex_iraf (ex) + case MIFF: # ImageMagick MIFF file + call ex_miff (ex) + case PGM: # PBMplus PGM (grayscale) file + call ex_pgm (ex) + case PPM: # PBMplus PPM (RGB) file + call ex_ppm (ex) + case RAS: # Sun rasterfile + call ex_ras (ex) + case RGB: # SGI RGB format file + call ex_rgb (ex) + case XWD: # X11 Window Dump + call ex_xwd (ex) + case VICAR: # JPL VICAR2 format image + call ex_vicar (ex) + default: + call error (0, "Unrecognized format") + } +end + + +# EXB_CHKPARS - Check the parameters for the builtin parameters. + +int procedure exb_chkpars (ex) + +pointer ex #i task struct pointer + +int legal, fmt + +begin + # Do a quick check that the number of expressions is valid for + # the requested format. + legal = NO + fmt = EX_BLTIN(ex) + switch (EX_NEXPR(ex)) { + case 1: + # PPM is the only format required to have 3 expressions. + if (fmt != PPM) + legal = YES + case 3: + if (fmt == PPM || fmt == RAS || fmt == RGB || + fmt == XWD || fmt == EPS || fmt == MIFF) + legal = YES + case 4: + if (fmt == RAS || fmt == XWD) + legal = YES + case EX_UNDEFINED: # let it slide for now.... + legal = YES + default: + if (bitset (EX_OUTFLAGS(ex), OF_BAND)) + legal = YES + } + if (legal == NO) { + call error (1, "Wrong no. of expressions for requested format") + return (ERR) + } + + # Check the bswap param. If it's set but ignored by a given format + # warn the user. + if (EX_BSWAP(ex) != S_NONE && (fmt != RAS && fmt != XWD)) { + call eprintf ("Warning: `bswap' parameter will be ignored") + return (ERR) + } + + return (OK) +end + + +# EXB_DO_FORMAT - Process a builtin task format parameter and set appropriate +# flags. + +procedure exb_do_format (ex, format) + +pointer ex #i task struct pointer +char format[ARB] #i format parameter value + +char fmt[SZ_FNAME] +int strdic() + +begin + switch (strdic (format, fmt, SZ_FNAME, EX_FORMATS)) { + case EPS, EPSI, EPI, EPSF, PS: + EX_BLTIN(ex) = EPS + EX_COLOR(ex) = YES + case GIF, GIFF: + EX_BLTIN(ex) = GIF + EX_COLOR(ex) = YES + case IMH, IRAF: + EX_BLTIN(ex) = IMH + EX_COLOR(ex) = NO + case MIFF: + EX_BLTIN(ex) = MIFF + EX_COLOR(ex) = YES + case PGM: + EX_BLTIN(ex) = PGM + EX_COLOR(ex) = NO + case PPM: + EX_BLTIN(ex) = PPM + EX_COLOR(ex) = NO + case RAS, SUN, SUNRAS: + EX_BLTIN(ex) = RAS + EX_COLOR(ex) = YES + case RGB, SGI, IRIS: + EX_BLTIN(ex) = RGB + EX_COLOR(ex) = NO + case XWD, X11: + EX_BLTIN(ex) = XWD + EX_COLOR(ex) = YES + case VICAR: + EX_BLTIN(ex) = VICAR + EX_COLOR(ex) = NO + default: + call error (2, "Unknown format.") + } +end + + +# EXB_PNAME - Print verbose name of the format. + +procedure exb_pname (ex) + +pointer ex #i task struct pointer + +begin + switch (EX_BLTIN(ex)) { + case EPS: + call pargstr ("Encapsulated PostScript") + case GIF: + call pargstr ("GIF") + case MIFF: + call pargstr ("ImageMagick MIFF") + case PGM: + call pargstr ("PGM") + case PPM: + call pargstr ("PPM") + case RAS: + call pargstr ("Sun Rasterfile") + case RGB: + call pargstr ("SGI RGB") + case XWD: + call pargstr ("X11 Window Dump") + case VICAR: + call pargstr ("JPL VICAR2 Image") + default: + call pargstr ("") + } +end + + +# EXB_PENDIAN - Print byte order of the format. + +procedure exb_pendian (ex) + +pointer ex #i task struct pointer + +begin + switch (EX_BLTIN(ex)) { + case GIF: + call pargstr ("Least Significant Byte First") + default: + if (EX_BSWAP(ex) == 0 && (BYTE_SWAP2==NO || BYTE_SWAP4==NO)) + call pargstr ("Most Significant Byte First") + else + call pargstr ("Least Significant Byte First") + } +end + + +# EXB_PSTORAGE - Print pixel storage type of the format. + +procedure exb_pstorage (ex) + +pointer ex #i task struct pointer + +int flags + +begin + switch (EX_BLTIN(ex)) { + case GIF: + call pargstr ("LZW compressed bytes") + case RGB: + call pargstr ("Band interleaved") + default: + flags = EX_OUTFLAGS(ex) + if (bitset(flags, OF_BAND) || bitset(flags,BAND_STORAGE)) + call pargstr ("Band Interleaved") + else if (bitset(flags, OF_LINE) || bitset(flags,LINE_STORAGE)) + call pargstr ("Line Interleaved") + else if (bitset(flags,PIXEL_STORAGE)) + call pargstr ("Pixel Interleaved") + else + call pargstr ("Unknown") + } +end + + +# EXB_FMT_EXT - Print the name of the builtin format. The returned pointer +# must be freed by the calling procedure. + +pointer procedure exb_fmt_ext (ex) + +pointer ex #i task struct pointer + +pointer suf + +begin + call malloc (suf, SZ_FNAME, TY_CHAR) + + switch (EX_BLTIN(ex)) { + case EPS: call strcpy (".eps", Memc[suf], SZ_FNAME) + case GIF: call strcpy (".gif", Memc[suf], SZ_FNAME) + case IMH: call strcpy (".imh", Memc[suf], SZ_FNAME) + case MIFF: call strcpy (".miff", Memc[suf], SZ_FNAME) + case PGM: call strcpy (".pgm", Memc[suf], SZ_FNAME) + case PPM: call strcpy (".ppm", Memc[suf], SZ_FNAME) + case RAS: call strcpy (".ras", Memc[suf], SZ_FNAME) + case RGB: call strcpy (".rgb", Memc[suf], SZ_FNAME) + case XWD: call strcpy (".xwd", Memc[suf], SZ_FNAME) + case VICAR: call strcpy (".vic", Memc[suf], SZ_FNAME) + default: Memc[suf] = EOS + } + + return (suf) +end diff --git a/pkg/dataio/export/excmap.x b/pkg/dataio/export/excmap.x new file mode 100644 index 00000000..486813ef --- /dev/null +++ b/pkg/dataio/export/excmap.x @@ -0,0 +1,258 @@ +include +include "export.h" + + +define EX_COLORMAPS "|aips0|blue|color|grayscale|greyscale|green|halley\ + |heat|rainbow|red|staircase|standard|overlay|" + +define AIPS0 1 # builtin colormaps +define BLUE 2 +define COLOR 3 +define GRAYSCALE 4 +define GREYSCALE 5 +define GREEN 6 +define HALLEY 7 +define HEAT 8 +define RAINBOW 9 +define RED 10 +define STAIRCASE 11 +define STANDARD 12 +define OVERLAY 13 + + +# EX_READ_CMAP - Read a colormap into the colormap structure. We assume the +# colormap is either a normalized CLT of RGB values between zero and one, or +# RGB integer values between 0 and 255. The format of the file is three +# values per line given as a red, green, and blue color. If the first line +# contains a single number assume it's the number of colors. A maximum of +# 256 colors will be read, if fewer values are read the remaining colors will +# be filled with zeros. + +procedure ex_read_cmap (ex, cmname) + +pointer ex #i colormap pointer +char cmname[ARB] #i colormap file name + +pointer cmap +pointer sp, line +real r, g, b, scale +int i, stat, fd, type, ncolors + +int open(), fscan(), nscan() +int getline(), lexnum(), strdic() +errchk open + +define rdmap_ 99 + +begin + # See if this is a builtin colormap request. + if (strdic(cmname,cmname,SZ_LINE,EX_COLORMAPS) > 0) { + call ex_bltin_cmap (ex, cmname) + return + } + + # Open the colormap filename. + iferr (fd = open (cmname, READ_ONLY, TEXT_FILE)) + call error (0, "Cannot open requested colormap file.") + + # Check the first line to see if it's the number of colors or a + # CLT entry. + stat = fscan (fd) + call gargr (r) + call gargr (g) + call gargr (b) + if (nscan() == 1) { + ncolors = r + goto rdmap_ + } else if (nscan() == 3) { + call seek (fd, BOF) +rdmap_ call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + stat = getline (fd, Memc[line]) + i = 1 + ncolors = 256 + type = lexnum (Memc[line], i, stat) + + if (type == LEX_REAL) + scale = 255.0 + else if (type == LEX_DECIMAL) + scale = 1.0 + else + call error (0, "Colormap file has an unknown format.") + + call sfree (sp) + } else + call error (1, "Colormap file has an unknown format.") + + # Read in a normalize colormap file. + cmap = EX_CMAP(ex) + for (i=1; fscan(fd) != EOF && i <= ncolors; i=i+1) { + call gargr (r) + call gargr (g) + call gargr (b) + + CMAP(cmap,EX_RED,i) = max (0, min (255, int (r * scale + 0.5))) + CMAP(cmap,EX_GREEN,i) = max (0, min (255, int (g * scale + 0.5))) + CMAP(cmap,EX_BLUE,i) = max (0, min (255, int (b * scale + 0.5))) + } + ncolors = i + EX_NCOLORS(ex) = ncolors + + # Close the file. + call close (fd) +end + + +# EX_SCALE_CMAP - Scale the colormap with the requested brightness and +# contrast values. + +procedure ex_scale_cmap (cmap, ncolors, brightness, contrast) + +pointer cmap #i colormap pointer +int ncolors #i number of colors in map +real brightness #i brightness offset +real contrast #i contrast scale + +pointer sp, ctmp +int i, c1, c2 +short r, g, b +real x, y, z, frac, slope, offset + +begin + call smark (sp) + call salloc (ctmp, 3*CMAP_SIZE, TY_CHAR) + call aclrc (Memc[ctmp], 3*CMAP_SIZE) + + slope = max (-7.0, min (7.0, contrast)) + offset = max (0.0, min (1.0, brightness)) + + # Compute the scaled colormap. + do i = 1, ncolors { + x = real (i) / real (ncolors) + y = (x - offset) * slope + 0.5 + + if (y <= 0.0) { + r = CMAP(cmap,EX_RED, 1) + g = CMAP(cmap,EX_GREEN,1) + b = CMAP(cmap,EX_BLUE, 1) + } else if (y >= 1.0) { + r = CMAP(cmap,EX_RED, ncolors) + g = CMAP(cmap,EX_GREEN,ncolors) + b = CMAP(cmap,EX_BLUE, ncolors) + } else { + z = y * (ncolors - 1) + c1 = max (1, int (z)) + c2 = min (ncolors-1, c1 + 1) + frac = z - c1 + r = CMAP(cmap,EX_RED,c1) * (1.0 - frac) + + CMAP(cmap,EX_RED,c2) * frac + g = CMAP(cmap,EX_GREEN,c1) * (1.0 - frac) + + CMAP(cmap,EX_GREEN,c2) * frac + b = CMAP(cmap,EX_BLUE,c1) * (1.0 - frac) + + CMAP(cmap,EX_BLUE,c2) * frac + } + + CMAP(ctmp,EX_RED, i) = r + CMAP(ctmp,EX_GREEN,i) = g + CMAP(ctmp,EX_BLUE, i) = b + } + call amovc (Memc[ctmp], Memc[cmap], 3*CMAP_SIZE) + + call sfree (sp) +end + + +# EX_BLTIN_CMAP - Load a predefined colormap. + +procedure ex_bltin_cmap (ex, cmname) + +pointer ex #i task struct pointer +char cmname[ARB] #i colormap name + +pointer cmap +int i, j, strdic() + +include "cmaps.inc" + +begin + j = 1 + cmap = EX_CMAP(ex) + EX_NCOLORS(ex) = CMAP_SIZE + + switch (strdic (cmname, cmname, SZ_LINE, EX_COLORMAPS)) { + case AIPS0: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = aips0[j] + CMAP(cmap,EX_GREEN,i) = aips0[j+1] + CMAP(cmap,EX_BLUE,i) = aips0[j+2] + j = j + 3 + } + case BLUE: + call aclrs (Mems[cmap], 3*CMAP_SIZE) + do i = 1, 256 + CMAP(cmap,EX_BLUE,i) = i - 1 + case COLOR: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = color[j] + CMAP(cmap,EX_GREEN,i) = color[j+1] + CMAP(cmap,EX_BLUE,i) = color[j+2] + j = j + 3 + } + case GRAYSCALE, GREYSCALE: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = i - 1 + CMAP(cmap,EX_GREEN,i) = i - 1 + CMAP(cmap,EX_BLUE,i) = i - 1 + } + case GREEN: + call aclrs (Mems[cmap], 3*CMAP_SIZE) + do i = 1, 256 + CMAP(cmap,EX_GREEN,i) = i - 1 + case HALLEY: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = halley[j] + CMAP(cmap,EX_GREEN,i) = halley[j+1] + CMAP(cmap,EX_BLUE,i) = halley[j+2] + j = j + 3 + } + case HEAT: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = heat[j] + CMAP(cmap,EX_GREEN,i) = heat[j+1] + CMAP(cmap,EX_BLUE,i) = heat[j+2] + j = j + 3 + } + case RAINBOW: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = rainbow[j] + CMAP(cmap,EX_GREEN,i) = rainbow[j+1] + CMAP(cmap,EX_BLUE,i) = rainbow[j+2] + j = j + 3 + } + case RED: + call aclrs (Mems[cmap], 3*CMAP_SIZE) + do i = 1, 256 + CMAP(cmap,EX_RED,i) = i - 1 + case STAIRCASE: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = staircase[j] + CMAP(cmap,EX_GREEN,i) = staircase[j+1] + CMAP(cmap,EX_BLUE,i) = staircase[j+2] + j = j + 3 + } + case STANDARD: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = standard[j] + CMAP(cmap,EX_GREEN,i) = standard[j+1] + CMAP(cmap,EX_BLUE,i) = standard[j+2] + j = j + 3 + } + case OVERLAY: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = overlay[j] + CMAP(cmap,EX_GREEN,i) = overlay[j+1] + CMAP(cmap,EX_BLUE,i) = overlay[j+2] + j = j + 3 + } + } +end diff --git a/pkg/dataio/export/exfcn.h b/pkg/dataio/export/exfcn.h new file mode 100644 index 00000000..7a9c61b3 --- /dev/null +++ b/pkg/dataio/export/exfcn.h @@ -0,0 +1,25 @@ +# EXFCN.H - Include file for the special functions supported by the EXPORT task. + +# Outbands expressions functions. +define OB_FUNCTIONS "|band|line|flipx|flipy|\ + |cmap|setcmap|psdpi|psscale|\ + |zscale|grey|gray|bscale|gamma|\ + |block|" + +define BAND 1 # force band-interleaved storage +define LINE 2 # force line-interleaved storage +define FLIPX 3 # flip image left-to-right +define FLIPY 4 # flip image top-to-bottom +#newline +define CMAP 6 # create 8-bit colormap +define SETCMAP 7 # apply a colormap +define PSDPI 8 # set dpi for output +define PSSCALE 9 # set scale of PS output +#newline +define ZSCALE 11 # scale to a fixed number of bins +define GREY 12 # RGB to greyscale conversion +define GRAY 13 # " " " " +define BSCALE 14 # linearly transform intensity scale +define GAMMA 15 # apply a gamma correction +#newline +define BLOCK 17 # floodfill a block w/ a constant diff --git a/pkg/dataio/export/exhdr.x b/pkg/dataio/export/exhdr.x new file mode 100644 index 00000000..9ba56a99 --- /dev/null +++ b/pkg/dataio/export/exhdr.x @@ -0,0 +1,207 @@ +include +include +include +include +include +include +include "export.h" + + +# EX_WHEADER - Write the output file header information. + +procedure ex_wheader (ex, outfile) + +pointer ex #i task struct pointer +char outfile[ARB] #i output file name + +pointer sp, tfile, buf, cbuf +int file_type, nchars + +int fd, open(), access(), strlen() +long fsize, fstatl() + +errchk open, access + +begin + if (EX_HEADER(ex) == HDR_SHORT || EX_HEADER(ex) == HDR_LONG) { + + call smark (sp) + call salloc (tfile, SZ_PATHNAME, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (cbuf, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[cbuf], SZ_LINE) + + # Write the generic header. + call mktemp ("tmp$ex", Memc[tfile], SZ_PATHNAME) + fd = open (Memc[tfile], NEW_FILE, TEXT_FILE) + call ex_mkheader (ex, fd) + call close (fd) + + if (EX_FORMAT(ex) != FMT_LIST) + fd = open (Memc[tfile], READ_ONLY, BINARY_FILE) + else + fd = open (Memc[tfile], READ_ONLY, TEXT_FILE) + fsize = fstatl (fd, F_FILESIZE) * SZB_CHAR + nchars = fsize + 27 #+ fsize/10 + call sprintf (Memc[buf], SZ_LINE, "format = EXPORT\nhdrsize = %d\n") + call pargi (nchars) + nchars = strlen (Memc[buf]) + if (EX_FD(ex) != STDOUT && EX_FORMAT(ex) != FMT_LIST) { + call strpak (Memc[buf], Memc[cbuf], nchars) + call write (EX_FD(ex), Memc[cbuf], nchars/SZB_CHAR) + call fcopyo (fd, EX_FD(ex)) + call close (fd) + } else { + call fprintf (EX_FD(ex), "%s") + call pargstr (Memc[buf]) + if (EX_FORMAT(ex) == FMT_LIST) + call fcopyo (fd, EX_FD(ex)) + else + call fcopy (Memc[tfile], "STDOUT") + + call close (fd) + } + + call delete (Memc[tfile]) + call sfree (sp) + + } else if (EX_HEADER(ex) == HDR_USER) { + # Copy user file to output. + iferr { + # If the user header is a text file we need to reopen the + # output file so the copy is done correctly. Afterwards + # we'll reopen it as a binary file. + if (access (HDRFILE(ex), 0, TEXT_FILE) == YES) { + file_type = TEXT_FILE + call close (EX_FD(ex)) + EX_FD(ex) = open (outfile, APPEND, file_type) + } else + file_type = BINARY_FILE + + fd = open (HDRFILE(ex), READ_ONLY, file_type) + call fcopyo (fd, EX_FD(ex)) + if (EX_FD(ex) != STDOUT) + call close (fd) + + if (file_type == TEXT_FILE) { + if (EX_FD(ex) != STDOUT) + call close (EX_FD(ex)) + if (EX_FORMAT(ex) != FMT_LIST) + EX_FD(ex) = open (outfile, APPEND, BINARY_FILE) + } + } then + call error (2, "Error writing user header.") + } +end + + +# EX_MKHEADER - Write the generic binary file header. Since we need to +# output the size we'll write out just the trailer part to the temp file +# and copy it to the real output file later. + +procedure ex_mkheader (ex, fd) + +pointer ex #i task struct pointer +int fd #i temp file descriptor + +long clktime() # seconds since 00:00:00 10-Jan-80 +int tm[LEN_TMSTRUCT] # broken down time structure + +begin + # Write the time stamp string. + call brktime (clktime(0), tm) + call fprintf (fd, "date = '%d/%d/%d'\n") + call pargi (TM_MDAY(tm)) + call pargi (TM_MONTH(tm)) + call pargi (TM_YEAR(tm)) + + # ... and the rest of the header + call fprintf (fd, "ncols = %d\n") # image dimensions + call pargi (EX_OCOLS(ex)) + call fprintf (fd, "nrows = %d\n") + call pargi (EX_OROWS(ex)) + call fprintf (fd, "nbands = %d\n") + call pargi (EX_NEXPR(ex)) + + call fprintf (fd, "datatype = '%s'\n") # pixel type + call pargstr (Memc[EX_OTPTR(ex)]) + + call fprintf (fd, "outbands = '%s'\n") # outbands expressions + call pargstr (Memc[EX_OBPTR(ex)]) + + call fprintf (fd, "interleave = %d\n") # pixel interleave type + call pargi (EX_INTERLEAVE(ex)) + + call fprintf (fd, "bswap = %s\n") # byte swapping flag + switch (EX_BSWAP(ex)) { + case S_NONE: call pargstr ("none") + case S_ALL: call pargstr ("all") + case S_I2: call pargstr ("i2") + case S_I4: call pargstr ("i4") + } + + if (EX_HEADER(ex) == HDR_LONG) + call ex_wimhdr (ex, fd) # write image headers + + # Terminate header. + call fprintf (fd, "end\n") +end + + +# EX_WIMHDR - Write the image header information. Include the headers if this +# is a verbose output. + +procedure ex_wimhdr (ex, fd) + +pointer ex #i task struct pointer +int fd #i temp file descriptor + +pointer sp, lbuf, ip, im +int i, in, ncols, min_lenuserarea +int stropen(), getline(), envgeti() + +define USER_AREA Memc[($1+IMU-1)*SZ_STRUCT + 1] +define LMARGIN 4 + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + do i = 1, EX_NIMAGES(ex) { + + im = IO_IMPTR(IMOP(ex,i)) + call fprintf (fd, "image%d = '%s'\n") + call pargi (i) + call pargstr (IM_HDRFILE(im)) + call fprintf (fd, "header%d {\n") + call pargi (i) + + # Open user area in header. + min_lenuserarea = (LEN_IMDES+IM_LENHDRMEM(im)-IMU) * SZ_STRUCT - 1 + in = stropen (USER_AREA(im), min_lenuserarea, READ_ONLY) + ncols = envgeti ("ttyncols") - LMARGIN + + # Copy header records to the output, stripping any trailing + # whitespace and clipping at the right margin. + + while (getline (in, Memc[lbuf]) != EOF) { + for (ip=lbuf; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + while (ip > lbuf && Memc[ip-1] == ' ') + ip = ip - 1 + if (ip - lbuf > ncols) + ip = lbuf + ncols + Memc[ip] = '\n' + Memc[ip+1] = EOS + + call putline (fd, " ") + call putline (fd, Memc[lbuf]) + } + + call fprintf (fd, "}\n") + } + + call close (in) + call sfree (sp) +end diff --git a/pkg/dataio/export/exobands.gx b/pkg/dataio/export/exobands.gx new file mode 100644 index 00000000..cd7313a3 --- /dev/null +++ b/pkg/dataio/export/exobands.gx @@ -0,0 +1,390 @@ +include +include +include +include +include +include "../export.h" +include "../exfcn.h" + +define DEBUG false +define VDEBUG false + + +# EX_EVALUATE -- Evaluate the outbands expression. + +pointer procedure ex_evaluate (ex, expr) + +pointer ex #i task struct pointer +char expr[ARB] #i expression to be evaluated + +pointer o # operand pointer to result + +int locpr() +pointer evvexpr() +extern ex_getop(), ex_obfcn() +errchk evvexpr + +begin + if (DEBUG) { call eprintf("ex_eval: expr='%s'\n") ; call pargstr(expr) } + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ex_getop), ex, locpr(ex_obfcn), ex, + EV_RNGCHK) + } then + call erract (EA_FATAL) + + return (o) +end + + +# EX_GETOP -- Called by evvexpr to get an operand. + +procedure ex_getop (ex, opname, o) + +pointer ex #i task struct pointer +char opname[ARB] #i operand name to retrieve +pointer o #o output operand pointer + +int i, nops, found, optype, imnum +pointer sp, buf +pointer op, param, emsg +pointer im + +#int ex_ptype() +int imgeti(), imgftype(), btoi(), ctoi() +bool streq(), imgetb() +double imgetd() + +define getpar_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (emsg, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[param], SZ_FNAME) + call aclrc (Memc[emsg], SZ_LINE) + + if (VDEBUG) { call eprintf ("getop: opname=%s ");call pargstr(opname)} + + # First see if it's one of the special image operands that was + # referenced in an "@param" call. + + if (((opname[1] != 'i' && opname[1] != 'b') && !IS_DIGIT(opname[2])) || + (opname[1] == 'i' && opname[2] == '_')) { + call strcpy (opname, Memc[param], SZ_FNAME) + im = IO_IMPTR(IMOP(ex,1)) +getpar_ O_LEN(o) = 0 + switch (imgftype (im, Memc[param])) { + case TY_BOOL: + O_TYPE(o) = TY_BOOL + O_VALI(o) = btoi (imgetb (im, Memc[param])) + case TY_CHAR: + O_TYPE(o) = TY_CHAR + O_LEN(o) = SZ_LINE + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + case TY_INT: + O_TYPE(o) = TY_INT + O_VALI(o) = imgeti (im, Memc[param]) + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + O_VALD(o) = imgetd (im, Memc[param]) + default: + call sprintf (Memc[emsg], SZ_LINE, "param %s not found\n") + call pargstr (Memc[param]) + call error (6, Memc[emsg]) + } + + call sfree (sp) + return + + } else if (IS_LOWER(opname[1]) && opname[3] == '.') { + # This is a tag.param operand. Break out the image tag name and + # get the image pointer for it, then get the parameter + if (opname[1] == 'b') { # band of 3-D image, only 1 ptr + imnum = 1 + } else if (opname[1] == 'i') { # image descriptor + i = 2 + if (ctoi (opname, i, imnum) == 0) + call error (6, "can't parse operand") + } else { + call sprintf (Memc[buf], SZ_LINE, + "Unknown outbands operand `%s'\n") + call pargstr(opname) + call error (1, Memc[buf]) + } + + # Get the parameter value. + im = IO_IMPTR(IMOP(ex,imnum)) + call strcpy (opname[4], Memc[param], SZ_FNAME) + goto getpar_ + } + + nops = EX_NIMOPS(ex) + found = NO + do i = 1, nops { + # Search for operand name which matches requested value. + op = IMOP(ex,i) + if (streq (Memc[IO_TAG(op)],opname)) { + found = YES + break + } + } + + if (VDEBUG && found == YES) { + call eprintf (" tag=%s found=%d ") + call pargstr(Memc[IO_TAG(op)]) ; call pargi(found) + call zze_prop (op) + } + + if (found == YES) { + # Copy operand descriptor to 'o' + #optype = ex_ptype (IO_TYPE(op), IO_NBYTES(op)) + optype = IO_TYPE(op) + switch (optype) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), IO_NPIX(op), TY_SHORT) + call amovs (Mems[IO_DATA(op)], Mems[O_VALP(o)], IO_NPIX(op)) + $for (ilrd) + case TY_PIXEL: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_PIXEL + call malloc (O_VALP(o), IO_NPIX(op), TY_PIXEL) + call amov$t (Mem$t[IO_DATA(op)], Mem$t[O_VALP(o)], IO_NPIX(op)) + $endfor + } + + } else { + call sprintf (Memc[buf], SZ_LINE, "Unknown outbands operand `%s'\n") + call pargstr(opname) + call error (1, Memc[buf]) + } + + call sfree (sp) +end + + +# EX_OBFCN -- Called by evvexpr to execute import outbands special functions. + +procedure ex_obfcn (ex, fcn, args, nargs, o) + +pointer ex #i package pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf +pointer r, g, b, gray +pointer scaled, data +int i, len, v_nargs, func, nbins +short sz1, sz2, sb1, sb2, zero +real gamma, bscale, bzero, scale, pix +real z1, z2 + +int strdic() +bool fp_equalr(), strne() + +define setop_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, OB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case GRAY, GREY: + v_nargs = 3 + case ZSCALE: + v_nargs = -1 + case BSCALE: + v_nargs = 3 + case GAMMA: + v_nargs = -1 + case BLOCK: + v_nargs = 3 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + if (DEBUG) { + call eprintf ("obfcn: nargs=%d func=%d\n") + call pargi (nargs) ; call pargi (func) + do i = 1, nargs { call eprintf ("\t") ; call zze_pevop (args[i]) } + call flush (STDERR) + } + + # Evaluate the function. + zero = 0 + switch (func) { + case GRAY, GREY: + # evaluate expression for NTSC grayscale. + r = O_VALP(args[1]) + g = O_VALP(args[2]) + b = O_VALP(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + gray = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mems[r+i] + + G_COEFF * Mems[g+i] + + B_COEFF * Mems[b+i] + } + $for (ilrd) + case TY_PIXEL: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mem$t[r+i] + + G_COEFF * Mem$t[g+i] + + B_COEFF * Mem$t[b+i] + } + $endfor + } + + case ZSCALE: + data = O_VALP(args[1]) + switch (O_TYPE(args[2])) { + case TY_SHORT: z1 = O_VALS(args[2]) + case TY_INT: z1 = O_VALI(args[2]) + case TY_LONG: z1 = O_VALL(args[2]) + case TY_REAL: z1 = O_VALR(args[2]) + case TY_DOUBLE: z1 = O_VALD(args[2]) + } + switch (O_TYPE(args[3])) { + case TY_SHORT: z2 = O_VALS(args[3]) + case TY_INT: z2 = O_VALI(args[3]) + case TY_LONG: z2 = O_VALL(args[3]) + case TY_REAL: z2 = O_VALR(args[3]) + case TY_DOUBLE: z2 = O_VALD(args[3]) + } + if (nargs < 4) + nbins = 256 + else + nbins = O_VALI(args[4]) + len = O_LEN(args[1]) + O_LEN(o) = len + O_TYPE(o) = O_TYPE(args[1]) + call malloc (O_VALP(o), len, O_TYPE(args[1])) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + sz1 = z1 + sz2 = z2 + sb1 = 0 + sb2 = nbins - 1 + if (abs(sz2-sz1) > 1.0e-5) + call amaps (Mems[data], Mems[scaled], len, sz1, sz2, + sb1, sb2) + else + call amovks (0, Mems[scaled], len) + $for (ilrd) + case TY_PIXEL: + if (abs(z2-z1) > 1.0e-5) + call amap$t (Mem$t[data], Mem$t[scaled], len, PIXEL (z1), + PIXEL(z2), PIXEL (0), PIXEL (nbins-1)) + else + call amovk$t (PIXEL (0), Mem$t[scaled], len) + $endfor + } + + case BSCALE: + data = O_VALP(args[1]) + bzero = O_VALR(args[2]) + bscale = O_VALR(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Mems[data+i] - bzero) / bscale + } else + call amovks (zero, Mems[scaled], len) + $for (ilrd) + case TY_PIXEL: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Mem$t[data+i] - bzero) / bscale + } else + call amovk$t (PIXEL(0), Mem$t[scaled], len) + $endfor + } + + case GAMMA: + data = O_VALP(args[1]) + gamma = 1.0 / O_VALR(args[2]) + if (nargs == 3) + scale = max (1.0, O_VALR(args[3])) + else + scale = 255.0 + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + pix = max (zero, Mems[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + $for (ilrd) + case TY_PIXEL: + do i = 0, len { + pix = max (PIXEL(0), Mem$t[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + $endfor + } + + case BLOCK: + len = O_VALI(args[2]) + O_LEN(o) = len + O_TYPE(o) = O_TYPE(args[1]) + call malloc (O_VALP(o), len, O_TYPE(args[1])) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovks (O_VALS(args[1]), Mems[scaled], len) + case TY_INT: + call amovki (O_VALI(args[1]), Memi[scaled], len) + case TY_LONG: + call amovkl (O_VALL(args[1]), Meml[scaled], len) + case TY_REAL: + call amovkr (O_VALR(args[1]), Memr[scaled], len) + case TY_DOUBLE: + call amovkd (O_VALD(args[1]), Memd[scaled], len) + } + + + } + + if (DEBUG) { call zze_pevop (o) } + + call sfree (sp) +end diff --git a/pkg/dataio/export/export.h b/pkg/dataio/export/export.h new file mode 100644 index 00000000..279e4378 --- /dev/null +++ b/pkg/dataio/export/export.h @@ -0,0 +1,155 @@ +# EXPORT.H -- Main include file for the task structure. + +# Main task structure. +define SZ_EXPSTRUCT 40 +define SZ_EXPSTR (20*SZ_LINE) +define EX_UNDEFINED -999 +define MAX_OBEXPR 250 +define MAX_OPERANDS 50 + + +define EX_FD Memi[$1] # output binary file descriptor +define EX_HEADER Memi[$1+1] # write an output header? +define EX_OUTTYPE Memi[$1+2] # outtype parameter value +define EX_INTERLEAVE Memi[$1+3] # interleave parameter value +define EX_BSWAP Memi[$1+4] # bswap parameter value +define EX_VERBOSE Memi[$1+5] # verbose parameter value + +define EX_FORMAT Memi[$1+6] # format parameter code +define EX_BLTIN Memi[$1+7] # buitlin format code +define EX_COLOR Memi[$1+8] # does format support color? +define EX_OROWS Memi[$1+9] # no. rows in output image +define EX_OCOLS Memi[$1+10] # no. cols in output image + +define EX_IMDIM Memi[$1+11] # input image list dimensionality +define EX_IMTYPE Memi[$1+12] # input image list type +define EX_NIMAGES Memi[$1+13] # number of images to convert +define EX_NCOLS Memi[$1+14] # number of columns in image +define EX_NLINES Memi[$1+15] # number of lines in image +define EX_NEXPR Memi[$1+16] # number of outbands expressions +define EX_NIMOPS Memi[$1+17] # image operand array (ptr) +define EX_IMOPS Memi[$1+18] # image operand array (ptr) + +define EX_OUTFLAGS Memi[$1+20] # output format flags +define EX_BFNPTR Memi[$1+21] # binary file name (ptr) +define EX_HDRPTR Memi[$1+22] # user-defined head file (ptr) +define EX_OTPTR Memi[$1+23] # output type string (ptr) +define EX_OBPTR Memi[$1+24] # outbands expression string (ptr) +define EX_CMPTR Memi[$1+25] # colormap filename (ptr) +define EX_LUTPTR Memi[$1+26] # LUT filename (ptr) +define EX_TIMPTR Memi[$1+27] # temp image name (ptr) +define EX_PSDPI Memr[P2R($1+28)] # EPS dpi resolution +define EX_PSSCALE Memr[P2R($1+29)] # EPS scale +define EX_BRIGHTNESS Memr[P2R($1+30)] # display brightness value +define EX_CONTRAST Memr[P2R($1+31)] # display contrast value + +define EX_CMAP Memi[$1+32] # colormap struct (ptr) +define EX_NCOLORS Memi[$1+33] # no. of colors in colormap +define EX_LUT Memi[$1+34] # LUT struct (ptr) +define EX_NLUTEL Memi[$1+35] # no. of indices in lut +define EX_OBANDS Memi[$1+36] # outbands array (ptr) + + +# Handy macros. +define HDRFILE Memc[EX_HDRPTR($1)] +define LUTFILE Memc[EX_LUTPTR($1)] +define CMAPFILE Memc[EX_CMPTR($1)] +define BFNAME Memc[EX_BFNPTR($1)] +define TIMNAME Memc[EX_TIMPTR($1)] +define OBANDS Memi[EX_OBANDS($1)+$2-1] +define IMOP Memi[EX_IMOPS($1)+$2-1] + + +# Define the outbands struct. +define LEN_OUTBANDS 5 +define OB_EXPSTR Memi[$1] # expression string (ptr) +define OB_WIDTH Memi[$1+1] # expression width +define OB_HEIGHT Memi[$1+2] # expression height + +define O_EXPR Memc[OB_EXPSTR(OBANDS($1,$2))] +define O_WIDTH OB_WIDTH(OBANDS($1,$2)) +define O_HEIGHT OB_HEIGHT(OBANDS($1,$2)) + + +# Operand structure. +define LEN_OPERAND 10 +define IO_IMPTR Memi[$1] # image descriptor +define IO_BAND Memi[$1+1] # image band +define IO_LINE Memi[$1+2] # image line + +define IO_TAG Memi[$1+3] # operand tag name +define IO_TYPE Memi[$1+4] # operand type +define IO_NBYTES Memi[$1+5] # number of bytes +define IO_NPIX Memi[$1+6] # number of pixels +define IO_DATA Memi[$1+7] # pixel ptr +define IO_ISIM Memi[$1+8] # is data an image ptr? + +define OP_TAG Memc[IO_TAG($1)] + +#----------------------------------------------------------------------------- +# Useful Macro Definitions. + +define bitset (and($1,$2)==($2)) + +# Format flags. +define FMT_RAW 1 # write a generic binary raster +define FMT_LIST 2 # list pixels values to the screen +define FMT_BUILTIN 3 # write a builtin format + +# OUTPUT FLAGS: +# Byte swapping flags. +define S_NONE 0000B # swap nothing +define S_ALL 0001B # swap everything +define S_I2 0002B # swap short ints +define S_I4 0004B # swap long ints +define SWAP_STR "|no|none|yes|i2|i4|" + +# Pixel storage flags. +define PIXEL_STORAGE 0001B # { {RGB} {RGB} ... {RGB} ... } +define LINE_STORAGE 0002B # { {RRRR} {GGG} {BBB} .... {RRR} ... } +define BAND_STORAGE 0004B # { {RR..RRR} {GG...GGG} {BB..BBB} } + +# Output flags. +define OF_CMAP 00010B # a colormap was defined +define OF_MKCMAP 00020B # compute a colormap +define OF_BAND 00040B # force band storage +define OF_LINE 00100B # force line storage +define OF_FLIPX 00200B # flip image in X +define OF_FLIPY 00400B # flip image in Y +define OF_IEEE 01000B # write IEEE floating point + +# Header flags. +define HDR_NONE 1 # no output header +define HDR_SHORT 2 # write a short header +define HDR_LONG 3 # write a verbose header +define HDR_USER 4 # user defined a file + +# Pixtype pixel types. +define PT_BYTE 1 # byte data (no conversion) +define PT_UINT 2 # unsigned integer +define PT_INT 3 # signed integer +define PT_IEEE 4 # ieee floating point +define PT_NATIVE 5 # native floating point +define PT_SKIP 6 # skip + +# EPS output params. +define EPS_DPI 72 # dpi resolution +define EPS_SCALE 1.0 # output scale + +# Define colormap/grayscale macros and parameters. +define CMAP_SIZE 256 # Output colormap length +define CMAP_MAX 255 # Maximum map value +define CMAP Memc[$1+($2*CMAP_SIZE)+$3-1] + +define R_COEFF 0.299 # NTSC grayscale coefficients +define G_COEFF 0.587 +define B_COEFF 0.114 + +define EX_RED 0 # color flags +define EX_GREEN 1 +define EX_BLUE 2 + +define SAMPLE_SIZE 10000 # default zscale() sample size +define CONTRAST 0.25 # default zscale() contrast +define SAMP_LEN 40 # default zscale() sample length + diff --git a/pkg/dataio/export/expreproc.x b/pkg/dataio/export/expreproc.x new file mode 100644 index 00000000..579f1fde --- /dev/null +++ b/pkg/dataio/export/expreproc.x @@ -0,0 +1,352 @@ +include +include +include "export.h" +include "exfcn.h" + +define DEBUG false + + +# EX_PREPROCESS - Some of the output functions aren't really applied to +# each line in the image (which is how the expressions are evaluated) but +# just define some feature of the whole output image. We'll strip out +# those functions here and set a flag so that the expression evaluation +# code doesn't have to see them. + +procedure ex_preprocess (ex, expr) + +pointer ex #i task struct pointer +char expr[ARB] #i input expression strings + +char expstr[SZ_EXPSTR] +int ip, pp, last_ip, explen +char func[SZ_FNAME] +bool saw_output_func + +int strlen(), strdic(), nowhite() + +errchk ex_pp_setcmap, ex_pp_psdpi +errchk ex_cnt_parens, ex_pp_psscale + +begin + # Strip out any whitespace chars. + call aclrc (expstr, SZ_EXPSTR) + ip = nowhite (expr, expstr, SZ_EXPSTR) + + # Do a quick syntax check. + iferr (call ex_cnt_parens (expstr)) + call erract (EA_FATAL) + + # Only some functions may be nested, loop until we're forced to break. + # The functions have a precedence such that "special functions" + # may have as arguments "output functions". Below that are "scaling + # functions" and "builtin functions" that are evaluated for each image + # line. Functions w/in the same class may/may not call each other + # where it makes sense, we check for that here. + # + # The precedence order is: + # + # CMAP, SETCMAP, PSDPI, PSSCALE + # BAND, LINE, FLIPX, FLIPY + # ZSCALE, GRAY, BSCALE, GAMMA + # builtin functions + + if (DEBUG) { call eprintf("preproc: str=`%s'\n");call pargstr(expstr) } + + saw_output_func = false + for (ip = 1 ; expstr[ip] == '(' ; ip = ip + 1) + ; + + last_ip = 1 + explen = strlen (expstr) + repeat { + # Get the function name. + pp = 1 + call aclrc (func, SZ_FNAME) + while (expstr[ip] != '(' && expstr[ip] != EOS) { + func[pp] = expstr[ip] + ip = ip + 1 + pp = pp + 1 + } + func[pp+1] = EOS + if (expstr[ip] == EOS) { + call strcpy (expstr[last_ip], expr, SZ_EXPSTR) + return + } + if (DEBUG) { call eprintf("\tfunc=`%s'\n");call pargstr(func) } + + # Update pointer into string past '('. + ip = ip + 1 + + switch (strdic (func, func, SZ_FNAME, OB_FUNCTIONS)) { + + case CMAP: + if (EX_NEXPR(ex) > 1) + call error (4, + "cmap() func allowed only in single expression") + if (saw_output_func) + call error (5, + "Function cmap() may not be nested in output func.") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_MKCMAP) + + case SETCMAP: + if (EX_NEXPR(ex) > 1) + call error (4, + "setcmap() func allowed only in single expression") + if (saw_output_func) + call error (5, + "Function setcmap(0 may not be nested in output func.") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_CMAP) + iferr (call ex_pp_setcmap (ex, expstr[ip])) + call erract (EA_FATAL) + last_ip = ip + explen = strlen (expstr) + next + + case PSDPI: + if (EX_NEXPR(ex) > 1) + call error (4, + "psdpi() func allowed only in single expression") + if (saw_output_func) + call error (5, + "Function psdpi() may not be nested in output func.") + iferr (call ex_pp_psdpi (ex, expstr[ip])) + call erract (EA_FATAL) + last_ip = ip + explen = strlen (expstr) + next + + case PSSCALE: + if (EX_NEXPR(ex) > 1) + call error (4, + "psscale() func allowed only in single expression") + if (saw_output_func) + call error (5, + "Function psscale() may not be nested in output func.") + iferr (call ex_pp_psscale (ex, expstr[ip])) + call erract (EA_FATAL) + last_ip = ip + explen = strlen (expstr) + next + + + case BAND: + saw_output_func = true + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_BAND) + case LINE: + saw_output_func = true + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_LINE) + case FLIPX: + saw_output_func = true + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPX) + case FLIPY: + saw_output_func = true + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + default: + # No special function seen so just punt. + break + } + + last_ip = ip # update string ptr + if (expstr[explen] != ')') + call error (5, + "Malformed expression, expecting ')' as last char") + expstr[explen] = EOS # remove trailing right paren + } + + # Copy expression from current ip to begining of buffer. + call strcpy (expstr[last_ip], expr, SZ_EXPSTR) + + if (DEBUG) { call eprintf("\tfixed exp =`%s'\n");call pargstr(expr) } +end + + +# EX_PP_SETCMAP - Process the SETCMAP special function. + +procedure ex_pp_setcmap (ex, expstr) + +pointer ex #i task struct pointer +char expstr[ARB] #i expression string + +pointer sp, cm, cmap +int ip, lp # string pointers +int tp, i # where to trim the string + +int ctor() +bool streq() +include "cmaps.inc" + +begin + call smark (sp) + call salloc (cm, SZ_FNAME, TY_CHAR) + call aclrc (Memc[cm], SZ_FNAME) + + if (DEBUG) { call eprintf("\t\texp=`%s'\n");call pargstr(expstr)} + + # Skip ahead to a quote char single or double) indicating colormap + # name, we also stop at another non-blank char incase they didn't + # use quotes. If we find a comma, back up one so it's handled below. + ip = 1 + while (expstr[ip] != EOS && + expstr[ip] != '"' && + expstr[ip] != '\'') { + if (expstr[ip] == '@') + for (ip=ip+2; expstr[ip] != '"'; ip=ip+1) + ; + ip = ip + 1 + } + tp = ip - 1 + + if (expstr[ip+1] == '"' || (expstr[ip+1]==' ' && expstr[ip+2]=='"') || + expstr[ip+1] == '\'' || (expstr[ip+1]==' ' && expstr[ip+2]=='\'')) { + # No colormap file specified, assume it's a greyscale. + call strcpy ("greyscale", CMAPFILE(ex), SZ_FNAME) + ip = ip + 1 + + } else { + # Get colormap name and put it in the task struct. + ip = ip + 1 + lp = 0 + repeat { + Memc[cm+lp] = expstr[ip] + lp = lp + 1 + ip = ip + 1 + } until (expstr[ip] == EOS || expstr[ip] == '"' || + expstr[ip] == '\'') + call strcpy (Memc[cm], CMAPFILE(ex), SZ_FNAME) + } + + # Allocate the colormap pointer and read the colormap. + iferr (call calloc (EX_CMAP(ex), 3*CMAP_SIZE, TY_CHAR)) + call error (0, "Error allocating colormap pointer.") + call ex_read_cmap (ex, CMAPFILE(ex)) + + # Get optional brightness and contrast values. + ip = ip + 1 + if (expstr[ip] == ',') { + ip = ip + 1 + if (ctor (expstr, ip, EX_BRIGHTNESS(ex)) == 0) + call error (5, "cannot interpret brightness value") + ip = ip + 1 + if (ctor (expstr, ip, EX_CONTRAST(ex)) == 0) + call error (5, "cannot interpret contrast value") + + # Don't scale the overlay colors in colormap. + if (streq(CMAPFILE(ex), "overlay")) { + cmap = EX_CMAP(ex) + call ex_scale_cmap (cmap, 200, + EX_BRIGHTNESS(ex), EX_CONTRAST(ex)) + + # Patch up the static overlay colors. + do i = 201, 255 { + Memc[cmap+(EX_RED*CMAP_SIZE)+i] = overlay[i*3+1] + Memc[cmap+(EX_GREEN*CMAP_SIZE)+i] = overlay[i*3+2] + Memc[cmap+(EX_BLUE*CMAP_SIZE)+i] = overlay[i*3+3] + } + } else { + call ex_scale_cmap (EX_CMAP(ex), EX_NCOLORS(ex), + EX_BRIGHTNESS(ex), EX_CONTRAST(ex)) + } + } + + # We should be at the end of the string now. + if (expstr[ip] != ')') + call error (5, "Malformed expression, expecting ')' as last char") + + if (DEBUG) { + call eprintf("\t\tcmfile=`%s' brightness=%g contrast=%g\n") + call pargstr(CMAPFILE(ex));call pargr(EX_BRIGHTNESS(ex)) + call pargr(EX_CONTRAST(ex)) + } + + # Now trim the expression string. + expstr[tp] = EOS + call sfree (sp) +end + + +# EX_PP_PSDPI - Process the PSDPI special function. + +procedure ex_pp_psdpi (ex, expstr) + +pointer ex #i task struct pointer +char expstr[ARB] #i expression string + +int ip, tp +int ctor(), strlen() + +begin + if (DEBUG) { call eprintf("\t\texp=`%s'\n");call pargstr(expstr)} + + # The last argument is required to be the dpi resolution so pull + # it out. + ip = strlen (expstr) + while (expstr[ip] != ',') { + ip = ip - 1 + if (expstr[ip] == ')' || IS_ALPHA(expstr[ip])) + call error (6, "syntax error") + } + + tp = ip + ip = ip + 1 + if (ctor(expstr,ip,EX_PSDPI(ex)) == 0) + call error (5, "cannot interpret EPS dpi value") + + # Now trim the expression string. + expstr[tp] = EOS +end + + +# EX_PP_PSSCALE - Process the PSSCALE special function. + +procedure ex_pp_psscale (ex, expstr) + +pointer ex #i task struct pointer +char expstr[ARB] #i expression string + +int ip, tp +int ctor(), strlen() + +begin + if (DEBUG) { call eprintf("\t\texp=`%s'\n");call pargstr(expstr)} + + # The last argument is required to be the dpi resolution so pull + # it out. + ip = strlen (expstr) + while (expstr[ip] != ',') { + ip = ip - 1 + if (expstr[ip] == ')' || IS_ALPHA(expstr[ip])) + call error (6, "syntax error") + } + + tp = ip + ip = ip + 1 + if (ctor(expstr,ip,EX_PSSCALE(ex)) == 0) + call error (5, "cannot interpret EPS scale value") + + # Now trim the expression string. + expstr[tp] = EOS +end + + +# EX_CNT_PARENS - Count the number of parentheses in the expression string. + +procedure ex_cnt_parens (expr) + +char expr[ARB] #i outbands expression strinf + +int ip, plev + +begin + ip = 1 + plev = 0 + while (expr[ip] != EOS) { + if (expr[ip] == '(') plev = plev + 1 + if (expr[ip] == ')') plev = plev - 1 + ip = ip + 1 + } + if (plev > 0) + call error (5, "Missing right paren in `outbands' expression.") + if (plev < 0) + call error (5, "Missing left paren in `outbands' expression.") +end diff --git a/pkg/dataio/export/exraster.gx b/pkg/dataio/export/exraster.gx new file mode 100644 index 00000000..a4c08710 --- /dev/null +++ b/pkg/dataio/export/exraster.gx @@ -0,0 +1,621 @@ +include +include +include +include "../export.h" + +define DEBUG false + + +# EX_NO_INTERLEAVE - Write out the image with no interleaving. + +procedure ex_no_interleave (ex) + +pointer ex #i task struct pointer + +pointer op, out +int i, j, k, line, percent, orow +int fd, outtype + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_no_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + # Loop over the number of image expressions. + fd = EX_FD(ex) + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NEXPR(ex) { + + # Process each line in the image. + do j = 1, O_HEIGHT(ex,i) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + #line = EX_NLINES(ex) - j + 1 + line = O_HEIGHT(ex,i) - j + 1 + else + line = j + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,i)) + + # Convert to the output pixel type. + out = ex_chtype (ex, op, outtype) + + # Write evaluated pixels. + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, out, O_LEN(op)) + else { + call ex_listpix (fd, outtype, out, O_LEN(op), j, i, + EX_NEXPR(ex), NO) + } + + # Clean up the pointers. + if (outtype == TY_UBYTE || outtype == TY_CHAR) + call mfree (out, TY_CHAR) + else + call mfree (out, outtype) + call evvfree (op) + do k = 1, EX_NIMOPS(ex) { + op = IMOP(ex,k) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + } + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_LN_INTERLEAVE - Write out the image with line interleaving. + +procedure ex_ln_interleave (ex) + +pointer ex #i task struct pointer + +pointer op, out +int i, j, line, percent, orow +int fd, outtype + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_ln_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + # Process each line in the image. + fd = EX_FD(ex) + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NLINES(ex) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - i + 1 + else + line = i + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Loop over the number of image expressions. + do j = 1, EX_NEXPR(ex) { + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,j)) + + # Convert to the output pixel type. + out = ex_chtype (ex, op, outtype) + + # Write evaluated pixels. + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, out, O_LEN(op)) + else { + call ex_listpix (fd, outtype, out, O_LEN(op), i, j, + EX_NEXPR(ex), NO) + } + + # Clean up the pointers. + if (outtype == TY_UBYTE || outtype == TY_CHAR) + call mfree (out, TY_CHAR) + else + call mfree (out, outtype) + call evvfree (op) + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + + do j = 1, EX_NIMOPS(ex) { + op = IMOP(ex,j) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + } + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_PX_INTERLEAVE - Write out the image with pixel interleaving. + +procedure ex_px_interleave (ex) + +pointer ex #i task struct pointer + +pointer sp, pp, op +pointer o, outptr +int i, j, line, npix, outtype +long totpix +int fd, percent, orow + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_px_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + call smark (sp) + call salloc (pp, EX_NEXPR(ex), TY_POINTER) + + # Process each line in the image. + fd = EX_FD(ex) + outptr = NULL + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NLINES(ex) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - i + 1 + else + line = i + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Loop over the number of image expressions. + totpix = 0 + do j = 1, EX_NEXPR(ex) { + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,j)) + + # Convert to the output pixel type. + o = ex_chtype (ex, op, outtype) + Memi[pp+j-1] = o + + npix = O_LEN(op) + #npix = EX_OCOLS(op) + call evvfree (op) + } + + # Merge pixels into a single vector. + call ex_merge_pixels (Memi[pp], EX_NEXPR(ex), npix, outtype, + outptr, totpix) + + # Write vector of merged pixels. + if (outtype == TY_UBYTE) + call achtsb (Memc[outptr], Memc[outptr], totpix) + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, outptr, totpix) + else { + call ex_listpix (fd, outtype, outptr, totpix, + i, EX_NEXPR(ex), EX_NEXPR(ex), YES) + } + + if (outtype != TY_CHAR && outtype != TY_UBYTE) + call mfree (outptr, outtype) + else + call mfree (outptr, TY_CHAR) + do j = 1, EX_NIMOPS(ex) { + op = IMOP(ex,j) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + do j = 1, EX_NEXPR(ex) { + if (outtype != TY_CHAR && outtype != TY_UBYTE) + call mfree (Memi[pp+j-1], outtype) + else + call mfree (Memi[pp+j-1], TY_CHAR) + } + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + + call sfree (sp) + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_GETPIX - Get the pixels from the image and load each operand. + +procedure ex_getpix (ex, line) + +pointer ex #i task struct pointer +int line #i current line number + +pointer im, op, data +int nptrs, i, band + +pointer imgl3s(), imgl3i(), imgl3l() +pointer imgl3r(), imgl3d() + +begin + # Loop over each of the image operands. + nptrs = EX_NIMOPS(ex) + do i = 1, nptrs { + op = IMOP(ex,i) + im = IO_IMPTR(op) + band = max (1, IO_BAND(op)) + + if (line > IM_LEN(im,2)) { + call calloc (IO_DATA(op), IM_LEN(im,1), IM_PIXTYPE(im)) + IO_ISIM(op) = NO + IO_NPIX(op) = IM_LEN(im,1) + next + } else if (IO_DATA(op) == NULL) + call malloc (IO_DATA(op), IM_LEN(im,1), IM_PIXTYPE(im)) + + switch (IM_PIXTYPE(im)) { + case TY_USHORT: + data = imgl3s (im, line, band) + call amovs (Mems[data], Mems[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_SHORT + IO_NBYTES(op) = SZ_SHORT * SZB_CHAR + IO_ISIM(op) = YES + $for (silrd) + case TY_PIXEL: + data = imgl3$t (im, line, band) + call amov$t (Mem$t[data], Mem$t[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_PIXEL + $if (datatype == i) + IO_NBYTES(op) = SZ_INT32 * SZB_CHAR + $else + IO_NBYTES(op) = SZ_PIXEL * SZB_CHAR + $endif + IO_ISIM(op) = YES + $endfor + } + IO_NPIX(op) = IM_LEN(im,1) + } +end + + +# EX_WPIXELS - Write the pixels to the current file. + +procedure ex_wpixels (fd, otype, pix, npix) + +int fd #i output file descriptor +int otype #i output data type +pointer pix #i pointer to pixel data +int npix #i number of pixels to write + +begin + # Write binary output. + switch (otype) { + case TY_UBYTE: + call write (fd, Mems[pix], npix / SZB_CHAR) + case TY_USHORT: + call write (fd, Mems[pix], npix * SZ_SHORT/SZ_CHAR) + $for (silrd) + case TY_PIXEL: + $if (datatype == i) + if (SZ_INT != SZ_INT32) + call ipak32 (Memi[pix], Memi[pix], npix) + call write (fd, Memi[pix], npix * SZ_INT32/SZ_CHAR) + $else + call write (fd, Mem$t[pix], npix * SZ_PIXEL/SZ_CHAR) + $endif + $endfor + } +end + + +# EX_LISTPIX - Write the pixels to the current file as ASCII text. + +procedure ex_listpix (fd, type, data, npix, line, band, nbands, merged) + +int fd #i output file descriptor +int type #i output data type +pointer data #i pointer to pixel data +int npix #i number of pixels to write +int line #i current output line number +int band #i current output band number +int nbands #i no. of output bands +int merged #i are pixels interleaved? + +int i, j, k +int val, pix, shifti(), andi() + +begin + if (merged == YES && nbands > 1) { + do i = 1, npix { + k = 0 + do j = 1, nbands { + call fprintf (fd, "%4d %4d %4d ") + call pargi (i) + call pargi (line) + call pargi (j) + + switch (type) { + case TY_UBYTE: + val = Memc[data+k] + if (mod(i,2) == 1) { + pix = shifti (val, -8) + } else { + pix = andi (val, 000FFX) + k = k + 1 + } + if (pix < 0) pix = pix + 256 + call fprintf (fd, "%d\n") + call pargi (pix) + case TY_CHAR, TY_SHORT, TY_USHORT: + call fprintf (fd, "%d\n") + call pargs (Mems[data+((j-1)*npix+i)-1]) + case TY_INT: + call fprintf (fd, "%d\n") + call pargi (Memi[data+((j-1)*npix+i)-1]) + case TY_LONG: + call fprintf (fd, "%d\n") + call pargl (Meml[data+((j-1)*npix+i)-1]) + case TY_REAL: + call fprintf (fd, "%g\n") + call pargr (Memr[data+((j-1)*npix+i)-1]) + case TY_DOUBLE: + call fprintf (fd, "%g\n") + call pargd (Memd[data+((j-1)*npix+i)-1]) + } + } + } + } else { + j = 0 + do i = 1, npix { + if (nbands > 1) { + call fprintf (fd, "%4d %4d %4d ") + call pargi (i) + call pargi (line) + call pargi (band) + } else { + call fprintf (fd, "%4d %4d ") + call pargi (i) + call pargi (line) + } + + switch (type) { + case TY_UBYTE: + val = Memc[data+j] + if (mod(i,2) == 1) { + pix = shifti (val, -8) + } else { + pix = andi (val, 000FFX) + j = j + 1 + } + if (pix < 0) pix = pix + 256 + call fprintf (fd, "%d\n") + call pargi (pix) + case TY_CHAR, TY_SHORT, TY_USHORT: + call fprintf (fd, "%d\n") + call pargs (Mems[data+i-1]) + case TY_INT: + call fprintf (fd, "%d\n") + call pargi (Memi[data+i-1]) + case TY_LONG: + call fprintf (fd, "%d\n") + call pargl (Meml[data+i-1]) + case TY_REAL: + call fprintf (fd, "%g\n") + call pargr (Memr[data+i-1]) + case TY_DOUBLE: + call fprintf (fd, "%g\n") + call pargd (Memd[data+i-1]) + } + } + } +end + + +# EX_MERGE_PIXELS - Merge a group of pixels arrays into one array by combining +# the elements. Returns an allocated pointer which must be later freed and +# the total number of pixels. + +procedure ex_merge_pixels (ptrs, nptrs, npix, dtype, pix, totpix) + +pointer ptrs[ARB] #i array of pixel ptrs +int nptrs #i number of ptrs +int npix #i no. of pixels in each array +int dtype #i type of pointer to alloc +pointer pix #o output pixel array ptr +int totpix #o total no. of output pixels + +int i, j, ip + +begin + # Calculate the number of output pixels and allocate the pointer. + totpix = nptrs * npix + if (dtype != TY_CHAR && dtype != TY_UBYTE) + call realloc (pix, totpix, dtype) + else { + call realloc (pix, totpix, TY_CHAR) + do i = 1, nptrs + call achtbs (Mems[ptrs[i]], Mems[ptrs[i]], npix) + } + + # Fill the output array + ip = 0 + for (i = 1; i<=npix; i=i+1) { + do j = 1, nptrs { + switch (dtype) { + case TY_UBYTE: + Mems[pix+ip] = Mems[ptrs[j]+i-1] + case TY_USHORT: + Mems[pix+ip] = Mems[ptrs[j]+i-1] + $for (silrd) + case TY_PIXEL: + Mem$t[pix+ip] = Mem$t[ptrs[j]+i-1] + $endfor + } + + ip = ip + 1 + } + } +end + + +# EX_CHTYPE - Change the expression operand vector to the output datatype. +# We allocate and return a pointer to the correct type to the converted +# pixels, this pointer must be freed later on. Any IEEE or byte-swapping +# requests are also handled here. + +pointer procedure ex_chtype (ex, op, type) + +pointer ex #i task struct pointer +pointer op #i evvexpr operand pointer +int type #i new type of pointer + +pointer out, coerce() +int swap, flags + +begin + # Allocate the pointer and coerce it so the routine works. + if (type == TY_UBYTE || type == TY_CHAR) + call calloc (out, O_LEN(op), TY_CHAR) + else { + call calloc (out, O_LEN(op), type) + out = coerce (out, type, TY_CHAR) + } + + # If this is a color index image subtract one from the pixel value + # to get the index. + if (bitset (flags, OF_CMAP)) + call ex_pix_to_index (O_VALP(op), O_TYPE(op), O_LEN(op)) + + # Change the pixel type. + flags = EX_OUTFLAGS(ex) + swap = EX_BSWAP(ex) + switch (O_TYPE(op)) { + case TY_CHAR: + call achtc (Memc[O_VALP(op)], Memc[out], O_LEN(op), type) + + case TY_SHORT: + call achts (Mems[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I2) || bitset (swap, S_ALL)) + call bswap4 (Mems[out], 1, Mems[out], 1, O_LEN(op)) + + case TY_INT: + call achti (Memi[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I4) || bitset (swap, S_ALL)) + call bswap4 (Memi[out], 1, Memi[out], 1, O_LEN(op)) + + case TY_LONG: + call achtl (Meml[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I4) || bitset (swap, S_ALL)) + call bswap4 (Meml[out], 1, Meml[out], 1, O_LEN(op)) + + case TY_REAL: + call achtr (Memr[O_VALP(op)], Memc[out], O_LEN(op), type) + + # See if we need to convert to IEEE + if (bitset (flags, OF_IEEE) && IEEE_USED == NO) + call ieevpakr (Memr[out], Memr[out], O_LEN(op)) + + case TY_DOUBLE: + call achtd (Memd[O_VALP(op)], Memc[out], O_LEN(op), type) + + # See if we need to convert to IEEE + if (bitset (flags, OF_IEEE) && IEEE_USED == NO) + call ieevpakd (Memd[P2D(out)], Memd[P2D(out)], O_LEN(op)) + + default: + call error (0, "Invalid output type requested.") + } + + if (type != TY_UBYTE && type != TY_CHAR) + out = coerce (out, TY_CHAR, type) + return (out) +end + + +# EX_PIX_TO_INDEX - Convert pixel values to color index values. We assume +# the colormap has at most 256 entries. + +procedure ex_pix_to_index (ptr, type, len) + +pointer ptr #i data ptr +int type #i data type of array +int len #i length of array + +$for (silrd) +PIXEL $tindx, $tmin, $tmax +$endfor + +begin + $for (silrd) + $tindx = PIXEL (1) + $tmin = PIXEL (0) + $tmax = PIXEL (255) + $endfor + + switch (type) { + $for (silrd) + case TY_PIXEL: + call asubk$t (Mem$t[ptr], $tindx, Mem$t[ptr], len) + call amaxk$t (Mem$t[ptr], $tmin, Mem$t[ptr], len) + call amink$t (Mem$t[ptr], $tmax, Mem$t[ptr], len) + $endfor + } +end + + +# EX_PSTAT - Print information about the progress we're making. + +procedure ex_pstat (ex, row, percent) + +pointer ex #i task struct pointer +int row #u current row +int percent #u percent completed + +begin + # Print percent done if being verbose + if (row * 100 / EX_OROWS(ex) >= percent + 10) { + percent = percent + 10 + call eprintf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDERR) + } +end diff --git a/pkg/dataio/export/exrgb8.x b/pkg/dataio/export/exrgb8.x new file mode 100644 index 00000000..9eac4705 --- /dev/null +++ b/pkg/dataio/export/exrgb8.x @@ -0,0 +1,994 @@ +include +include "export.h" + + +# Size definitions +define A_BITS 8 # Number of bits of color +define B_BITS 5 # Number of bits/pixel to use +define C_BITS 3 # Number of cells/color to use +define A_LEN 256 # 2 ** A_BITS +define B_LEN 32 # 2 ** B_BITS +define C_LEN 8 # 2 ** C_BITS +define AB_SHIFT 8 # 2 ** (A_BITS - B_BITS) +define BC_SHIFT 4 # 2 ** (B_BITS - C_BITS) +define AC_SHIFT 32 # 2 ** (A_BITS - C_BITS) + +# Color metric definitions +define R2FACT 20 # .300 * .300 * 256 = 23 +define G2FACT 39 # .586 * .586 * 256 = 88 +define B2FACT 8 # .114 * .114 * 256 = 3 + +define RED 1 +define GREEN 2 +define BLUE 3 + +# Colorbox structure +define CBOX_LEN 9 +define CBOX_NEXT Memi[$1] # pointer to next colorbox structure +define CBOX_PREV Memi[$1+1] # pointer to previous colorbox structure +define CBOX_RMIN Memi[$1+2] +define CBOX_RMAX Memi[$1+3] +define CBOX_GMIN Memi[$1+4] +define CBOX_GMAX Memi[$1+5] +define CBOX_BMIN Memi[$1+6] +define CBOX_BMAX Memi[$1+7] +define CBOX_TOTAL Memi[$1+8] + +# Color cell structure +define CCELL_LEN (A_LEN*2+1) +define CCELL_NUM_ENTS Memi[$1] +define CCELL_ENTRIES Memi[$1+2*($2)+$3+1] + +# Output number of colors +define NCOLORS 256 + + +# EX_MKCMAP -- Generate an 8-bit colormap from three input image expressions +# using Heckbert's Median Cut algorithm. The implementation of this algorithm +# was modeled, with permission, on that in the program XV written by John +# Bradley. + +procedure ex_mkcmap (ex) + +pointer ex #i task struct pointer + +pointer oim # Output image +real z1[3], dz[3] # Display ranges + +int i, ncolors +pointer sp, cmap, box_list, histogram, ColorCells +pointer freeboxes, usedboxes, ptr, im + +pointer immap(), cm_largest_box() +errchk open, immap + +begin + # Since we're creating a colormap we force the output pixel size + # to be 8-bits. + call ex_do_outtype (ex, "b1") + + # Create a temporary image of the processed expressions. We'll + # evaluate the expressions only once an save the results, later + # we'll path up the operand and expressions structs to it copies + # this out to the requested format. + + if (EX_TIMPTR(ex) == NULL) + call calloc (EX_TIMPTR(ex), SZ_FNAME, TY_CHAR) + else + call aclrc (TIMNAME(ex), SZ_FNAME) + call mktemp ("tmp$ex", TIMNAME(ex), SZ_FNAME) + oim = immap (TIMNAME(ex), NEW_IMAGE, 0) + IM_PIXTYPE(oim) = TY_SHORT + IM_LEN(oim,1) = EX_OCOLS(ex) + IM_LEN(oim,2) = EX_OROWS(ex) + IM_NDIM(oim) = 2 + + # Set input image intensity scaling. + z1[1] = 0.0 + dz[1] = 1.0 + z1[2] = 0.0 + dz[2] = 1.0 + z1[3] = 0.0 + dz[3] = 1.0 + + # Allocate color map. + ncolors = NCOLORS + call smark (sp) + call salloc (cmap, 3 * ncolors, TY_SHORT) + + # Allocate and initialize color boxes. + call salloc (box_list, ncolors * CBOX_LEN, TY_STRUCT) + + freeboxes = box_list + usedboxes = NULL + ptr = freeboxes + CBOX_PREV(ptr) = NULL + CBOX_NEXT(ptr) = ptr + CBOX_LEN + for (i=2; i CBOX_RMIN(tmp) || + CBOX_GMAX(tmp) > CBOX_GMIN(tmp) || + CBOX_BMAX(tmp) > CBOX_BMIN(tmp)) && + CBOX_TOTAL(tmp) > size) { + ptr = tmp + size = CBOX_TOTAL(tmp) + } + } + return(ptr) +end + + +# CM_SPLITBOX -- Split a box along largest dimension + +procedure cm_splitbox (box, usedboxes, freeboxes, histogram) + +pointer box #U Box to split +pointer usedboxes #U Used boxes +pointer freeboxes #U Free boxes +int histogram[B_LEN, B_LEN, B_LEN] #I Histogram + +int first, last, i, j, rdel, gdel, bdel, sum1, sum2 +pointer sp, hist, new +int ir, ig, ib +int rmin, rmax, gmin, gmax, bmin, bmax +int which + +begin + call smark (sp) + call salloc (hist, B_LEN, TY_INT) + + # see which axis is the largest, do a histogram along that + # axis. Split at median point. Contract both new boxes to + # fit points and return + + first = 1; last = 1 + rmin = CBOX_RMIN(box); rmax = CBOX_RMAX(box) + gmin = CBOX_GMIN(box); gmax = CBOX_GMAX(box) + bmin = CBOX_BMIN(box); bmax = CBOX_BMAX(box) + + rdel = rmax - rmin + gdel = gmax - gmin + bdel = bmax - bmin + + if (rdel>=gdel && rdel>=bdel) + which = RED + else if (gdel>=bdel) + which = GREEN + else + which = BLUE + + # get histogram along longest axis + switch (which) { + case RED: + for (ir=rmin; ir<=rmax; ir=ir+1) { + sum1 = 0 + for (ig=gmin; ig<=gmax; ig=ig+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + sum1 = sum1 + histogram[ir,ig,ib] + } + } + Memi[hist+ir-1] = sum1 + } + first = rmin; last = rmax + + case GREEN: + for (ig=gmin; ig<=gmax; ig=ig+1) { + sum1 = 0 + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + sum1 = sum1 + histogram[ir,ig,ib] + } + } + Memi[hist+ig-1] = sum1 + } + first = gmin; last = gmax + + case BLUE: + for (ib=bmin; ib<=bmax; ib=ib+1) { + sum1 = 0 + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + sum1 = sum1 + histogram[ir,ig,ib] + } + } + Memi[hist+ib-1] = sum1 + } + first = bmin; last = bmax + } + + + # find median point + sum1 = 0 + sum2 = CBOX_TOTAL(box) / 2 + for (i=first; i<=last; i=i+1) { + sum1 = sum1 + Memi[hist+i-1] + if (sum1 >= sum2) + break + } + if (i == first) + i = i + 1 + + + # Create new box, re-allocate points + + new = freeboxes + freeboxes = CBOX_NEXT(new) + if (freeboxes != NULL) + CBOX_PREV(freeboxes) = NULL + if (usedboxes != NULL) + CBOX_PREV(usedboxes) = new + CBOX_NEXT(new) = usedboxes + usedboxes = new + + sum1 = 0 + sum2 = 0 + for (j = first; j < i; j=j+1) + sum1 = sum1 + Memi[hist+j-1] + for (; j <= last; j=j+1) + sum2 = sum2 + Memi[hist+j-1] + CBOX_TOTAL(new) = sum1 + CBOX_TOTAL(box) = sum2 + + CBOX_RMIN(new) = rmin; CBOX_RMAX(new) = rmax + CBOX_GMIN(new) = gmin; CBOX_GMAX(new) = gmax + CBOX_BMIN(new) = bmin; CBOX_BMAX(new) = bmax + + switch (which) { + case RED: + CBOX_RMAX(new) = i-1; CBOX_RMIN(box) = i + case GREEN: + CBOX_GMAX(new) = i-1; CBOX_GMIN(box) = i + case BLUE: + CBOX_BMAX(new) = i-1; CBOX_BMIN(box) = i + } + + call cm_shrinkbox (new, histogram) + call cm_shrinkbox (box, histogram) + call sfree (sp) +end + + +# CM_SHRINKBOX -- Shrink box + +procedure cm_shrinkbox (box, histogram) + +pointer box #U Box +int histogram[B_LEN,B_LEN,B_LEN] #I Histogram + +int ir, ig, ib +int rmin, rmax, gmin, gmax, bmin, bmax + +define have_rmin 11 +define have_rmax 12 +define have_gmin 13 +define have_gmax 14 +define have_bmin 15 +define have_bmax 16 + +begin + + rmin = CBOX_RMIN(box); rmax = CBOX_RMAX(box) + gmin = CBOX_GMIN(box); gmax = CBOX_GMAX(box) + bmin = CBOX_BMIN(box); bmax = CBOX_BMAX(box) + + if (rmax > rmin) { + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + if (histogram[ir,ig,ib] != 0) { + rmin = ir + CBOX_RMIN(box) = rmin + goto have_rmin + } + } + } + } + +have_rmin + if (rmax > rmin) { + for (ir=rmax; ir>=rmin; ir=ir-1) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + if (histogram[ir,ig,ib] != 0) { + rmax = ir + CBOX_RMAX(box) = rmax + goto have_rmax + } + } + } + } + } + } + + +have_rmax + if (gmax > gmin) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + if (histogram[ir,ig,ib] != 0) { + gmin = ig + CBOX_GMIN(box) = gmin + goto have_gmin + } + } + } + } + +have_gmin + if (gmax > gmin) { + for (ig=gmax; ig>=gmin; ig=ig-1) { + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + if (histogram[ir,ig,ib] != 0) { + gmax = ig + CBOX_GMAX(box) = gmax + goto have_gmax + } + } + } + } + } + } + +have_gmax + if (bmax > bmin) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + if (histogram[ir,ig,ib] != 0) { + bmin = ib + CBOX_BMIN(box) = bmin + goto have_bmin + } + } + } + } + +have_bmin + if (bmax > bmin) { + for (ib=bmax; ib>=bmin; ib=ib-1) { + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + if (histogram[ir,ig,ib] != 0) { + bmax = ib + CBOX_BMAX(box) = bmax + goto have_bmax + } + } + } + } + } + } + +have_bmax + return +end + + + +# CM_ASSIGN_COLOR -- Assign colors + +procedure cm_assign_color (box, cmap) + +pointer box #I Box +short cmap[3] #O Color map entry + +begin + # +1 ensures that color represents the middle of the box + + cmap[1] = ((CBOX_RMIN(box) + CBOX_RMAX(box) - 2) * AB_SHIFT) / 2 + cmap[2] = ((CBOX_GMIN(box) + CBOX_GMAX(box) - 2) * AB_SHIFT) / 2 + cmap[3] = ((CBOX_BMIN(box) + CBOX_BMAX(box) - 2) * AB_SHIFT) / 2 +end + + + +# CM_MAP_COLORTABLE -- Map the color table + +procedure cm_map_colortable (histogram, cmap, ncolor, ColorCells) + +int histogram[B_LEN,B_LEN,B_LEN] #U Histogram +short cmap[3,ncolor] #I Color map +int ncolor #I Number of colors +pointer ColorCells[C_LEN,C_LEN,C_LEN] #O Color cells + +int i, j, ir, ig, ib, rcell, bcell, gcell +long dist, d2, tmp +pointer cell, cm_create_colorcell() + +begin + for (ir=0; irCCELL_ENTRIES(cell,i,1); i=i+1) { + j = CCELL_ENTRIES(cell,i,0) + d2 = cmap[1,1+j] - (ir * BC_SHIFT) + d2 = (d2 * d2 * R2FACT) + tmp = cmap[2,1+j] - (ig * BC_SHIFT) + d2 = d2 + (tmp*tmp * G2FACT) + tmp = cmap[3,1+j] - (ib * BC_SHIFT) + d2 = d2 + (tmp*tmp * B2FACT) + if (d2 < dist) { + dist = d2 + histogram[1+ir,1+ig,1+ib] = j + } + } + } + } + } + } +end + + + +# CM_CREATE_COLORCELL -- Create a color cell structure + +pointer procedure cm_create_colorcell (ColorCells, ra, ga, ba, cmap, ncolor) + +pointer ColorCells[C_LEN,C_LEN,C_LEN] #U Color cells +int ra, ga, ba #I Color to create cell for +short cmap[3,ncolor] #I Color map +int ncolor #I Number of colors + +int i, n, next_n, ir,ig,ib, r1,g1,b1 +long dist, mindist, tmp +pointer ptr + +begin + ir = ra / AC_SHIFT + ig = ga / AC_SHIFT + ib = ba / AC_SHIFT + + r1 = ir * AC_SHIFT + g1 = ig * AC_SHIFT + b1 = ib * AC_SHIFT + + call malloc (ptr, CCELL_LEN, TY_STRUCT) + ColorCells[1+ir,1+ig,1+ib] = ptr + CCELL_NUM_ENTS(ptr) = 0 + + # step 1: find all colors inside this cell, while we're at + # it, find distance of centermost point to furthest corner + + mindist = 2000000000 + + for (i=1; i<=ncolor; i=i+1) { + if (cmap[1,i]/AC_SHIFT == ir && + cmap[2,i]/AC_SHIFT == ig && + cmap[3,i]/AC_SHIFT == ib) { + CCELL_ENTRIES(ptr,CCELL_NUM_ENTS(ptr),0) = i - 1 + CCELL_ENTRIES(ptr,CCELL_NUM_ENTS(ptr),1) = 0 + CCELL_NUM_ENTS(ptr) = CCELL_NUM_ENTS(ptr) + 1 + + tmp = cmap[1,i] - r1 + if (tmp < (A_LEN/C_LEN/2)) + tmp = A_LEN/C_LEN-1 - tmp + dist = (tmp*tmp * R2FACT) + + tmp = cmap[2,i] - g1 + if (tmp < (A_LEN/C_LEN/2)) + tmp = A_LEN/C_LEN-1 - tmp + dist = dist + (tmp*tmp * G2FACT) + + tmp = cmap[3,i] - b1 + if (tmp < (A_LEN/C_LEN/2)) + tmp = A_LEN/C_LEN-1 - tmp + dist = dist + (tmp*tmp * B2FACT) + + mindist = min (mindist, dist) + } + } + + + # step 3: find all points within that distance to box + + for (i=1; i<=ncolor; i=i+1) { + if (cmap[1,i]/AC_SHIFT != ir || + cmap[2,i]/AC_SHIFT != ig || + cmap[3,i]/AC_SHIFT != ib) { + dist = 0 + tmp = r1 - cmap[1,i] + if (tmp>0) { + dist = dist + (tmp*tmp * R2FACT) + } else { + tmp = cmap[1,i] - (r1 + A_LEN/C_LEN-1) + if (tmp > 0) + dist = dist + (tmp*tmp * R2FACT) + } + + tmp = g1 - cmap[2,i] + if (tmp>0) { + dist = dist + (tmp*tmp * G2FACT) + } else { + tmp = cmap[2,i] - (g1 + A_LEN/C_LEN-1) + if (tmp > 0) + dist = dist + (tmp*tmp * G2FACT) + } + + tmp = b1 - cmap[3,i] + if (tmp>0) { + dist = dist + (tmp*tmp * B2FACT) + } else { + tmp = cmap[3,i] - (b1 + A_LEN/C_LEN-1) + if (tmp > 0) + dist = dist + (tmp*tmp * B2FACT) + } + + if (dist < mindist) { + CCELL_ENTRIES(ptr,CCELL_NUM_ENTS(ptr),0) = i - 1 + CCELL_ENTRIES(ptr,CCELL_NUM_ENTS(ptr),1) = dist + CCELL_NUM_ENTS(ptr) = CCELL_NUM_ENTS(ptr) + 1 + } + } + } + + + # sort color cells by distance, use cheap exchange sort + n = CCELL_NUM_ENTS(ptr) - 1 + while (n > 0) { + next_n = 0 + for (i=0; i CCELL_ENTRIES(ptr,i+1,1)) { + tmp = CCELL_ENTRIES(ptr,i,0) + CCELL_ENTRIES(ptr,i,0) = CCELL_ENTRIES(ptr,i+1,0) + CCELL_ENTRIES(ptr,i+1,0) = tmp + tmp = CCELL_ENTRIES(ptr,i,1) + CCELL_ENTRIES(ptr,i,1) = CCELL_ENTRIES(ptr,i+1,1) + CCELL_ENTRIES(ptr,i+1,1) = tmp + next_n = i + } + } + n = next_n + } + + return (ptr) +end + + + +# CM_QUANT_FSDITHER -- Quantized Floyd-Steinberg Dither + +procedure cm_quant_fsdither (ex, z1, dz, histogram, + ColorCells, cmap, ncolor, oim) + +pointer ex #I task struct pointer +real z1[3] #I Intensity mapping origins +real dz[3] #I Intensity mapping ranges +int histogram[B_LEN,B_LEN,B_LEN] #U Histogram +pointer ColorCells[C_LEN,C_LEN,C_LEN] #U Color cell data +short cmap[3,ncolor] #I Color map +int ncolor #I Number of colors +pointer oim #O Output IMIO pointer + +pointer thisptr, nextptr, optr, impl2s() +pointer sp, thisline, nextline, tmpptr +int ir, ig, ib, r1, g1, b1, rcell, bcell, gcell +int i, j, nc, nl, oval + +int ci, cj +long dist, d2, tmp +pointer cell + +pointer cm_create_colorcell() + +begin + nc = EX_OCOLS(ex) + nl = EX_OROWS(ex) + + call smark (sp) + call salloc (thisline, nc * 3, TY_INT) + call salloc (nextline, nc * 3, TY_INT) + + # get first line of picture + call cm_getline (ex, z1, dz, 1, nextline) + + for (i=1; i<=nl; i=i+1) { + # swap thisline and nextline + tmpptr = thisline + thisline = nextline + nextline = tmpptr + + # read in next line + if (i < nl) + #call cm_getline (ex, z1, dz, i, nextline, nc) + call cm_getline (ex, z1, dz, i, nextline) + + # dither this line and put it into the output picture + thisptr = thisline + nextptr = nextline + optr = impl2s (oim, i) + + for (j=1; j<=nc; j=j+1) { + r1 = Memi[thisptr] + g1 = Memi[thisptr+1] + b1 = Memi[thisptr+2] + thisptr = thisptr + 3 + + r1 = max (0, min (A_LEN-1, r1)) + g1 = max (0, min (A_LEN-1, g1)) + b1 = max (0, min (A_LEN-1, b1)) + + ir = r1 / AB_SHIFT + ig = g1 / AB_SHIFT + ib = b1 / AB_SHIFT + + oval = histogram[1+ir,1+ig,1+ib] + if (oval == -1) { + rcell = 1 + ir / BC_SHIFT + gcell = 1 + ig / BC_SHIFT + bcell = 1 + ib / BC_SHIFT + cell = ColorCells[rcell, gcell, bcell] + if (cell == NULL) + cell = cm_create_colorcell (ColorCells, r1, g1, b1, + cmap, ncolor) + + dist = 2000000000 + for (ci=0; ciCCELL_ENTRIES(cell,ci,1); ci=ci+1) { + cj = CCELL_ENTRIES(cell,ci,0) + d2 = (cmap[1,1+cj]/AB_SHIFT) - ir + d2 = (d2*d2 * R2FACT) + tmp = (cmap[2,1+cj]/AB_SHIFT) - ig + d2 = d2 + (tmp*tmp * G2FACT) + tmp = (cmap[3,1+cj]/AB_SHIFT) - ib + d2 = d2 + (tmp*tmp * B2FACT) + if (d2 1) { + tmpptr = nextptr - 3 + if (r1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (r1*3-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (r1*3+8)/16 + tmpptr = tmpptr + 1 + if (g1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (g1*3-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (g1*3+8)/16 + tmpptr = tmpptr + 1 + if (b1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (b1*3-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (b1*3+8)/16 + } + + tmpptr = nextptr + if (r1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (r1*5-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (r1*5+8)/16 + tmpptr = tmpptr + 1 + if (g1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (g1*5-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (g1*5+8)/16 + tmpptr = tmpptr + 1 + if (b1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (b1*5-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (b1*5+8)/16 + + if (j < nc) { + tmpptr = nextptr + 3 + if (r1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (r1-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (r1+8)/16 + tmpptr = tmpptr + 1 + if (g1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (g1-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (g1+8)/16 + tmpptr = tmpptr + 1 + if (b1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (b1-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (b1+8)/16 + } + nextptr = nextptr + 3 + } + } + } + + # Flush the pixels to the output image, otherwise we end up with an + # odd line which may or may not be actual pixels. + call imflush (oim) + + call sfree (sp) +end diff --git a/pkg/dataio/export/exzscale.x b/pkg/dataio/export/exzscale.x new file mode 100644 index 00000000..f0a4b506 --- /dev/null +++ b/pkg/dataio/export/exzscale.x @@ -0,0 +1,755 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "export.h" + +define DEBUG false + + +.help ex_zscale +.nf ___________________________________________________________________________ +EX_ZSCALE -- Compute the optimal Z1, Z2 (range of greyscale values to be +displayed) of an expression. For efficiency a statistical subsample of the +expression is used. The pixel sample evenly subsamples the expression in x +and y. The entire expression is used if the number of pixels in the expression +is smaller than the desired sample. + +The sample is accumulated in a buffer and sorted by greyscale value. +The median value is the central value of the sorted array. The slope of a +straight line fitted to the sorted sample is a measure of the standard +deviation of the sample about the median value. Our algorithm is to sort +the sample and perform an iterative fit of a straight line to the sample, +using pixel rejection to omit gross deviants near the endpoints. The fitted +straight line is the transfer function used to map image Z into display Z. +If more than half the pixels are rejected the full range is used. The slope +of the fitted line is divided by the user-supplied contrast factor and the +final Z1 and Z2 are computed, taking the origin of the fitted line at the +median value. +.endhelp ______________________________________________________________________ + +define MIN_NPIXELS 5 # smallest permissible sample +define MAX_REJECT 0.5 # max frac. of pixels to be rejected +define GOOD_PIXEL 0 # use pixel in fit +define BAD_PIXEL 1 # ignore pixel in all computations +define REJECT_PIXEL 2 # reject pixel after a bit +define KREJ 2.5 # k-sigma pixel rejection factor +define MAX_ITERATIONS 5 # maximum number of fitline iterations + + +# EX_PATCH_ZSCALE - Rather than compute the optimal zscale values for each +# line in the expression we'll go through the expression string and compute +# the values here. The expression string is modified with the values so that +# when evaluated they are seen as arguments to the function. + +procedure ex_patch_zscale (ex, expnum) + +pointer ex #i task struct pointer +int expnum #i expression number to fix + +pointer sp, exp, func +int ip, pp + +bool streq() + +begin + call smark (sp) + call salloc (exp, SZ_EXPSTR, TY_CHAR) + call salloc (func, SZ_FNAME, TY_CHAR) + call aclrc(Memc[exp], SZ_EXPSTR) + call aclrc(Memc[func], SZ_FNAME) + + # Copy the final expression string to the output buffer. + call strcpy (O_EXPR(ex,expnum), Memc[exp], SZ_EXPSTR) + + # Now fix up any zscale functions calls embedded in the expression. + ip = 0 + repeat { + # Skip ahead to a possible zscale()/mzscale() call. + while (Memc[exp+ip] != 'z' && Memc[exp+ip] != EOS) + ip = ip + 1 + if (Memc[exp+ip] == EOS) + break + + # Get the function name. + pp = 0 + call aclrc (Memc[func], SZ_FNAME) + while (Memc[exp+ip] != '(' && Memc[exp+ip] != EOS) { + Memc[func+pp] = Memc[exp+ip] + ip = ip + 1 + pp = pp + 1 + } + Memc[func+pp+1] = EOS + if (Memc[exp+ip] == EOS) + break + + if (DEBUG) { call eprintf("\tfunc=`%s'\n");call pargstr(Memc[func])} + + # Update pointer into string past '('. + ip = ip + 1 + + if (streq(Memc[func],"zscale") || streq(Memc[func],"zscalem")) { + iferr (call ex_edit_zscale (ex, Memc[exp], ip+1)) + call erract (EA_FATAL) + ip = ip + 1 + } + } + + # Copy the final expression string to the output buffer. + call strcpy (Memc[exp], O_EXPR(ex,expnum), SZ_EXPSTR) + + call sfree (sp) +end + + +# EX_EDIT_ZSCALE - Process the ZSCALE special function. This function requires +# preprocessing in the event the user didn't supply a z1/z2 value. What +# we'll do here is pre-compute those values and patch up the expression +# string. Otherwise we'll make sure the rest of the arguments are legal. + +procedure ex_edit_zscale (ex, expstr, pp) + +pointer ex #i task struct pointer +char expstr[ARB] #i expression string +int pp #i position pointer + +pointer sp, arg, arg2, exp, buf +pointer exptr, exptr2, ep +char ch +int ip, op, tp, tp2, plev +real z1, z2 + +pointer ex_evaluate() + +begin + call smark (sp) + call salloc (arg, SZ_EXPSTR, TY_CHAR); call aclrc (Memc[arg], SZ_EXPSTR) + call salloc (arg2, SZ_EXPSTR,TY_CHAR); call aclrc (Memc[arg2],SZ_EXPSTR) + call salloc (exp, SZ_EXPSTR, TY_CHAR); call aclrc (Memc[exp], SZ_EXPSTR) + call salloc (buf, SZ_EXPSTR, TY_CHAR); call aclrc (Memc[buf], SZ_EXPSTR) + + if (DEBUG) { call eprintf("\t\texp=`%s'\n");call pargstr(expstr)} + + # Gather the expression argument. + ip = pp + op = 0 + plev = 0 + repeat { + ch = expstr[ip] + if (ch == '(') plev = plev + 1 + if (ch == ')') plev = plev - 1 + Memc[arg+op] = ch + if ((ch == ',' && plev == 0) || (ch == ')' && plev < 0)) + break + ip = ip + 1 + op = op + 1 + } + Memc[arg+op] = EOS + tp = ip - 1 + tp2 = tp + if (DEBUG) {call eprintf("\t\targ = `%s'\n");call pargstr(Memc[arg])} + + # Gather the mask argument. + if (expstr[pp-2] == 'm' && ch == ',') { + ip = ip + 1 + op = 0 + plev = 0 + repeat { + ch = expstr[ip] + if (ch == '(') plev = plev + 1 + if (ch == ')') plev = plev - 1 + Memc[arg2+op] = ch + if ((ch == ',' && plev == 0) || (ch == ')' && plev < 0)) + break + ip = ip + 1 + op = op + 1 + } + Memc[arg2+op] = EOS + tp2 = ip - 1 + if (DEBUG) { + call eprintf("\t\targ2 = `%s'\n") + call pargstr(Memc[arg2]) + } + } + + if (ch == ',') { + # We have more arguments, assume they're okay and return. + call sfree (sp) + return + + } else if (ch == ')') { + # This is the end of the zscale function, so compute the optimal + # z1/z2 values for the given expression. First, dummy up an out- + # bands pointer. + + call ex_alloc_outbands (exptr) + call strcpy (Memc[arg], Memc[OB_EXPSTR(exptr)], SZ_EXPSTR) + + # Get the size of the expression. + call ex_getpix (ex, 1) + ep = ex_evaluate (ex, Memc[OB_EXPSTR(exptr)]) + OB_WIDTH(exptr) = O_LEN(ep) + call evvfree (ep) + if (OB_WIDTH(exptr) == 0) + OB_HEIGHT(exptr) = 1 + else + OB_HEIGHT(exptr) = EX_NLINES(ex) + + # Setup the mask expression if needed. + if (Memc[arg2] != EOS) { + call ex_alloc_outbands (exptr2) + call strcpy (Memc[arg2], Memc[OB_EXPSTR(exptr2)], SZ_EXPSTR) + + # Get the size of the expression. + ep = ex_evaluate (ex, Memc[OB_EXPSTR(exptr2)]) + OB_WIDTH(exptr2) = O_LEN(ep) + call evvfree (ep) + if (OB_WIDTH(exptr2) == 0) + OB_HEIGHT(exptr2) = 1 + else + OB_HEIGHT(exptr2) = EX_NLINES(ex) + if (OB_WIDTH(exptr2) != OB_WIDTH(exptr) || + OB_WIDTH(exptr2) != OB_WIDTH(exptr)) + call error (1, "Sizes of zscalem arguments not the same.") + } else + exptr2 = NULL + + if (EX_VERBOSE(ex) == YES) { + call printf ("Computing zscale values...") + call flush (STDOUT) + } + + call ex_zscale (ex, exptr, exptr2, z1, z2, + CONTRAST, SAMPLE_SIZE, SAMP_LEN) + call ex_free_outbands (exptr) + if (exptr2 != NULL) + call ex_free_outbands (exptr2) + + if (DEBUG) {call eprintf("\t\t\tz1=%g z2=%g\n") + call pargr(z1) ; call pargr (z2) } + + # Now patch up the expression string to insert the computed values. + if (expstr[pp-2] == 'm') { + call strcpy (expstr, Memc[exp], pp-3) + call strcat (expstr[pp-1], Memc[exp], tp-1) + } else + call strcpy (expstr, Memc[exp], tp) + call sprintf (Memc[buf], SZ_EXPSTR, ",%g,%g,256") + call pargr (z1) + call pargr (z2) + call strcat (Memc[buf], Memc[exp], SZ_EXPSTR) + call strcat (expstr[tp2+1], Memc[exp], SZ_EXPSTR) + + # Print the computed values to the screen. + if (EX_VERBOSE(ex) == YES) { + call printf ("z1=%g z2=%g\n") + call pargr (z1) + call pargr (z2) + } + } + + # Copy fixed-up expression to input buffer. + call aclrc (expstr, SZ_EXPSTR) + call strcpy (Memc[exp], expstr, SZ_EXPSTR) + + if (DEBUG){call eprintf("\t\tnew expr=`%s'\n");call pargstr(expstr)} + + call sfree (sp) +end + + +# EX_ZSCALE -- Sample the expression and compute Z1 and Z2. + +procedure ex_zscale (ex, exptr, exptr2, z1, z2, contrast, optimal_sample_size, + len_stdline) + +pointer ex # task struct pointer +pointer exptr # expression struct pointer +pointer exptr2 # expression struct pointer (mask) +real z1, z2 # output min and max greyscale values +real contrast # adj. to slope of transfer function +int optimal_sample_size # desired number of pixels in sample +int len_stdline # optimal number of pixels per line + +int npix, minpix, ngoodpix, center_pixel, ngrow +real zmin, zmax, median +real zstart, zslope +pointer sample, left +int ex_sample_expr(), ex_fit_line() + +begin + # Subsample the expression. + npix = ex_sample_expr (ex, exptr, exptr2, sample, optimal_sample_size, + len_stdline) + center_pixel = max (1, (npix + 1) / 2) + + # Sort the sample, compute the minimum, maximum, and median pixel + # values. + + call asrtr (Memr[sample], Memr[sample], npix) + zmin = Memr[sample] + zmax = Memr[sample+npix-1] + + # The median value is the average of the two central values if there + # are an even number of pixels in the sample. + + left = sample + center_pixel - 1 + if (mod (npix, 2) == 1 || center_pixel >= npix) + median = Memr[left] + else + median = (Memr[left] + Memr[left+1]) / 2 + + # Fit a line to the sorted sample vector. If more than half of the + # pixels in the sample are rejected give up and return the full range. + # If the user-supplied contrast factor is not 1.0 adjust the scale + # accordingly and compute Z1 and Z2, the y intercepts at indices 1 and + # npix. + + minpix = max (MIN_NPIXELS, int (npix * MAX_REJECT)) + ngrow = max (1, nint (npix * .01)) + ngoodpix = ex_fit_line (Memr[sample], npix, zstart, zslope, + KREJ, ngrow, MAX_ITERATIONS) + + if (ngoodpix < minpix) { + z1 = zmin + z2 = zmax + } else { + if (contrast > 0) + zslope = zslope / contrast + z1 = max (zmin, median - (center_pixel - 1) * zslope) + z2 = min (zmax, median + (npix - center_pixel) * zslope) + } + + call mfree (sample, TY_REAL) +end + + +# EX_SAMPLE_EXPR -- Extract an evenly gridded subsample of the pixels from +# a possibly two-dimensional expression into a one-dimensional vector. + +int procedure ex_sample_expr (ex, exptr, exptr2, sample, optimal_sample_size, + len_stdline) + +pointer ex # task struct pointer +pointer exptr # expression struct pointer +pointer exptr2 # expression struct pointer (mask) +pointer sample # output vector containing the sample +int optimal_sample_size # desired number of pixels in sample +int len_stdline # optimal number of pixels per line + +pointer op, ep, out, bpm +int ncols, nlines, col_step, line_step, maxpix, line +int opt_npix_per_line, npix_per_line, nsubsample +int opt_nlines_in_sample, min_nlines_in_sample, max_nlines_in_sample + +pointer ex_evaluate() + +begin + ncols = OB_WIDTH(exptr) + nlines = OB_HEIGHT(exptr) + + # Compute the number of pixels each line will contribute to the sample, + # and the subsampling step size for a line. The sampling grid must + # span the whole line on a uniform grid. + + opt_npix_per_line = max (1, min (ncols, len_stdline)) + col_step = max (1, (ncols + opt_npix_per_line-1) / opt_npix_per_line) + npix_per_line = max (1, (ncols + col_step-1) / col_step) + + # Compute the number of lines to sample and the spacing between lines. + # We must ensure that the image is adequately sampled despite its + # size, hence there is a lower limit on the number of lines in the + # sample. We also want to minimize the number of lines accessed when + # accessing a large image, because each disk seek and read is expensive. + # The number of lines extracted will be roughly the sample size divided + # by len_stdline, possibly more if the lines are very short. + + min_nlines_in_sample = max (1, optimal_sample_size / len_stdline) + opt_nlines_in_sample = max(min_nlines_in_sample, min(nlines, + (optimal_sample_size + npix_per_line-1) / npix_per_line)) + line_step = max (1, nlines / (opt_nlines_in_sample)) + max_nlines_in_sample = (nlines + line_step-1) / line_step + + # Allocate space for the output vector. Buffer must be freed by our + # caller. + + maxpix = npix_per_line * max_nlines_in_sample + call malloc (sample, maxpix, TY_REAL) + + # Extract the vector. + op = sample + call malloc (out, ncols, TY_REAL) + if (exptr2 != NULL) + call malloc (bpm, ncols, TY_INT) + do line = (line_step + 1) / 2, nlines, line_step { + + # Evaluate the expression at the current line. + call ex_getpix (ex, line) + ep = ex_evaluate (ex, Memc[OB_EXPSTR(exptr)]) + switch (O_TYPE(ep)) { + case TY_CHAR: + call achtcr (Memc[O_VALP(ep)], Memr[out], O_LEN(ep)) + case TY_SHORT: + call achtsr (Mems[O_VALP(ep)], Memr[out], O_LEN(ep)) + case TY_INT: + call achtir (Memi[O_VALP(ep)], Memr[out], O_LEN(ep)) + case TY_LONG: + call achtlr (Meml[O_VALP(ep)], Memr[out], O_LEN(ep)) + case TY_REAL: + call amovr (Memr[O_VALP(ep)], Memr[out], O_LEN(ep)) + case TY_DOUBLE: + call achtdr (Memd[O_VALP(ep)], Memr[out], O_LEN(ep)) + default: + call error (0, "Unknown expression type in zscale/zscalem().") + } + call evvfree (ep) + if (exptr2 != NULL) { + ep = ex_evaluate (ex, Memc[OB_EXPSTR(exptr2)]) + switch (O_TYPE(ep)) { + case TY_BOOL: + call amovi (Memi[O_VALP(ep)], Memi[bpm], O_LEN(ep)) + default: + call error (0, + "Selection expression must be boolean in zscalem().") + } + call ex_subsample1 (Memr[out], Memi[bpm], Memr[op], O_LEN(ep), + npix_per_line, col_step, nsubsample) + call evvfree (ep) + } else + call ex_subsample (Memr[out], Memr[op], O_LEN(ep), + npix_per_line, col_step, nsubsample) + + op = op + nsubsample + if (op - sample + npix_per_line > maxpix) + break + } + call mfree (out, TY_REAL) + + return (op - sample) +end + + +# EX_SUBSAMPLE -- Subsample an image line. Extract the first pixel and +# every "step"th pixel thereafter for a total of npix pixels. + +procedure ex_subsample (a, b, n, npix, step, nsubsample) + +real a[n] +real b[npix] +int n +int npix, step, nsubsample +int ip, i + +begin + nsubsample = npix + if (step <= 1) + call amovr (a, b, npix) + else { + ip = 1 + do i = 1, npix { + b[i] = a[ip] + ip = ip + step + } + } +end + + +# EX_SUBSAMPLE1 -- Subsample an image line. Extract the first pixel and +# every "step"th pixel thereafter for a total of npix pixels. +# +# Check for mask values and exclude them from the sample. In case a +# subsampled line has fewer than 75% good pixels then increment the starting +# pixel and step through again. Return the number of good pixels. + +procedure ex_subsample1 (a, c, b, n, npix, step, nsubsample) + +real a[ARB] +int c[ARB] +real b[npix] +int n +int npix, step, nsubsample +int i, j + +begin + nsubsample = 0 + if (step <= 1) { + do i = 1, n { + if (c[i] == 0) + next + nsubsample = nsubsample + 1 + b[nsubsample] = a[i] + if (nsubsample == npix) + break + } + } else { + do j = 1, step-1 { + do i = j, n, step { + if (c[i] == 0) + next + nsubsample = nsubsample + 1 + b[nsubsample] = a[i] + if (nsubsample == npix) + break + } + if (nsubsample >= 0.75 * npix) + break + } + } +end + + +# EX_FIT_LINE -- Fit a straight line to a data array of type real. This is +# an iterative fitting algorithm, wherein points further than ksigma from the +# current fit are excluded from the next fit. Convergence occurs when the +# next iteration does not decrease the number of pixels in the fit, or when +# there are no pixels left. The number of pixels left after pixel rejection +# is returned as the function value. + +int procedure ex_fit_line (data, npix, zstart, zslope, krej, ngrow, maxiter) + +real data[npix] #i data to be fitted +int npix #i number of pixels before rejection +real zstart #o Z-value of pixel data[1] +real zslope #o dz/pixel +real krej #i k-sigma pixel rejection factor +int ngrow #i number of pixels of growing +int maxiter #i max iterations + +int i, ngoodpix, last_ngoodpix, minpix, niter +real xscale, z0, dz, x, z, mean, sigma, threshold +double sumxsqr, sumxz, sumz, sumx, rowrat +pointer sp, flat, badpix, normx +int ex_reject_pixels(), ex_compute_sigma() + +begin + if (npix <= 0) + return (0) + else if (npix == 1) { + zstart = data[1] + zslope = 0.0 + return (1) + } else + xscale = 2.0 / (npix - 1) + + # Allocate a buffer for data minus fitted curve, another for the + # normalized X values, and another to flag rejected pixels. + + call smark (sp) + call salloc (flat, npix, TY_REAL) + call salloc (normx, npix, TY_REAL) + call salloc (badpix, npix, TY_SHORT) + call aclrs (Mems[badpix], npix) + + # Compute normalized X vector. The data X values [1:npix] are + # normalized to the range [-1:1]. This diagonalizes the lsq matrix + # and reduces its condition number. + + do i = 0, npix - 1 + Memr[normx+i] = i * xscale - 1.0 + + # Fit a line with no pixel rejection. Accumulate the elements of the + # matrix and data vector. The matrix M is diagonal with + # M[1,1] = sum x**2 and M[2,2] = ngoodpix. The data vector is + # DV[1] = sum (data[i] * x[i]) and DV[2] = sum (data[i]). + + sumxsqr = 0 + sumxz = 0 + sumx = 0 + sumz = 0 + + do i = 1, npix { + x = Memr[normx+i-1] + z = data[i] + sumxsqr = sumxsqr + (x ** 2) + sumxz = sumxz + z * x + sumz = sumz + z + } + + # Solve for the coefficients of the fitted line. + z0 = sumz / npix + dz = sumxz / sumxsqr + + # Iterate, fitting a new line in each iteration. Compute the flattened + # data vector and the sigma of the flat vector. Compute the lower and + # upper k-sigma pixel rejection thresholds. Run down the flat array + # and detect pixels to be rejected from the fit. Reject pixels from + # the fit by subtracting their contributions from the matrix sums and + # marking the pixel as rejected. + + ngoodpix = npix + minpix = max (MIN_NPIXELS, int (npix * MAX_REJECT)) + + for (niter=1; niter <= maxiter; niter=niter+1) { + last_ngoodpix = ngoodpix + + # Subtract the fitted line from the data array. + call ex_flatten_data (data, Memr[flat], Memr[normx], npix, z0, dz) + + # Compute the k-sigma rejection threshold. In principle this + # could be more efficiently computed using the matrix sums + # accumulated when the line was fitted, but there are problems with + # numerical stability with that approach. + + ngoodpix = ex_compute_sigma (Memr[flat], Mems[badpix], npix, + mean, sigma) + threshold = sigma * krej + + # Detect and reject pixels further than ksigma from the fitted + # line. + ngoodpix = ex_reject_pixels (data, Memr[flat], Memr[normx], + Mems[badpix], npix, sumxsqr, sumxz, sumx, sumz, threshold, + ngrow) + + # Solve for the coefficients of the fitted line. Note that after + # pixel rejection the sum of the X values need no longer be zero. + + if (ngoodpix > 0) { + rowrat = sumx / sumxsqr + z0 = (sumz - rowrat * sumxz) / (ngoodpix - rowrat * sumx) + dz = (sumxz - z0 * sumx) / sumxsqr + } + + if (ngoodpix >= last_ngoodpix || ngoodpix < minpix) + break + } + + # Transform the line coefficients back to the X range [1:npix]. + zstart = z0 - dz + zslope = dz * xscale + + call sfree (sp) + return (ngoodpix) +end + + +# EX_FLATTEN_DATA -- Compute and subtract the fitted line from the data array, +# returned the flattened data in FLAT. + +procedure ex_flatten_data (data, flat, x, npix, z0, dz) + +real data[npix] # raw data array +real flat[npix] # flattened data (output) +real x[npix] # x value of each pixel +int npix # number of pixels +real z0, dz # z-intercept, dz/dx of fitted line +int i + +begin + do i = 1, npix + flat[i] = data[i] - (x[i] * dz + z0) +end + + +# EX_COMPUTE_SIGMA -- Compute the root mean square deviation from the +# mean of a flattened array. Ignore rejected pixels. + +int procedure ex_compute_sigma (a, badpix, npix, mean, sigma) + +real a[npix] # flattened data array +short badpix[npix] # bad pixel flags (!= 0 if bad pixel) +int npix +real mean, sigma # (output) + +real pixval +int i, ngoodpix +double sum, sumsq, temp + +begin + sum = 0 + sumsq = 0 + ngoodpix = 0 + + # Accumulate sum and sum of squares. + do i = 1, npix + if (badpix[i] == GOOD_PIXEL) { + pixval = a[i] + ngoodpix = ngoodpix + 1 + sum = sum + pixval + sumsq = sumsq + pixval ** 2 + } + + # Compute mean and sigma. + switch (ngoodpix) { + case 0: + mean = INDEF + sigma = INDEF + case 1: + mean = sum + sigma = INDEF + default: + mean = sum / ngoodpix + temp = sumsq / (ngoodpix - 1) - sum**2 / (ngoodpix * (ngoodpix - 1)) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngoodpix) +end + + +# EX_REJECT_PIXELS -- Detect and reject pixels more than "threshold" greyscale +# units from the fitted line. The residuals about the fitted line are given +# by the "flat" array, while the raw data is in "data". Each time a pixel +# is rejected subtract its contributions from the matrix sums and flag the +# pixel as rejected. When a pixel is rejected reject its neighbors out to +# a specified radius as well. This speeds up convergence considerably and +# produces a more stringent rejection criteria which takes advantage of the +# fact that bad pixels tend to be clumped. The number of pixels left in the +# fit is returned as the function value. + +int procedure ex_reject_pixels (data, flat, normx, badpix, npix, + sumxsqr, sumxz, sumx, sumz, threshold, ngrow) + +real data[npix] # raw data array +real flat[npix] # flattened data array +real normx[npix] # normalized x values of pixels +short badpix[npix] # bad pixel flags (!= 0 if bad pixel) +int npix +double sumxsqr,sumxz,sumx,sumz # matrix sums +real threshold # threshold for pixel rejection +int ngrow # number of pixels of growing + +int ngoodpix, i, j +real residual, lcut, hcut +double x, z + +begin + ngoodpix = npix + lcut = -threshold + hcut = threshold + + do i = 1, npix + if (badpix[i] == BAD_PIXEL) + ngoodpix = ngoodpix - 1 + else { + residual = flat[i] + if (residual < lcut || residual > hcut) { + # Reject the pixel and its neighbors out to the growing + # radius. We must be careful how we do this to avoid + # directional effects. Do not turn off thresholding on + # pixels in the forward direction; mark them for rejection + # but do not reject until they have been thresholded. + # If this is not done growing will not be symmetric. + + do j = max(1,i-ngrow), min(npix,i+ngrow) { + if (badpix[j] != BAD_PIXEL) { + if (j <= i) { + x = normx[j] + z = data[j] + sumxsqr = sumxsqr - (x ** 2) + sumxz = sumxz - z * x + sumx = sumx - x + sumz = sumz - z + badpix[j] = BAD_PIXEL + ngoodpix = ngoodpix - 1 + } else + badpix[j] = REJECT_PIXEL + } + } + } + } + + return (ngoodpix) +end diff --git a/pkg/dataio/export/generic/exobands.x b/pkg/dataio/export/generic/exobands.x new file mode 100644 index 00000000..d8a7d636 --- /dev/null +++ b/pkg/dataio/export/generic/exobands.x @@ -0,0 +1,489 @@ +include +include +include +include +include +include "../export.h" +include "../exfcn.h" + +define DEBUG false +define VDEBUG false + + +# EX_EVALUATE -- Evaluate the outbands expression. + +pointer procedure ex_evaluate (ex, expr) + +pointer ex #i task struct pointer +char expr[ARB] #i expression to be evaluated + +pointer o # operand pointer to result + +int locpr() +pointer evvexpr() +extern ex_getop(), ex_obfcn() +errchk evvexpr + +begin + if (DEBUG) { call eprintf("ex_eval: expr='%s'\n") ; call pargstr(expr) } + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ex_getop), ex, locpr(ex_obfcn), ex, + EV_RNGCHK) + } then + call erract (EA_FATAL) + + return (o) +end + + +# EX_GETOP -- Called by evvexpr to get an operand. + +procedure ex_getop (ex, opname, o) + +pointer ex #i task struct pointer +char opname[ARB] #i operand name to retrieve +pointer o #o output operand pointer + +int i, nops, found, optype, imnum +pointer sp, buf +pointer op, param, emsg +pointer im + +#int ex_ptype() +int imgeti(), imgftype(), btoi(), ctoi() +bool streq(), imgetb() +double imgetd() + +define getpar_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (emsg, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[param], SZ_FNAME) + call aclrc (Memc[emsg], SZ_LINE) + + if (VDEBUG) { call eprintf ("getop: opname=%s ");call pargstr(opname)} + + # First see if it's one of the special image operands that was + # referenced in an "@param" call. + + if (((opname[1] != 'i' && opname[1] != 'b') && !IS_DIGIT(opname[2])) || + (opname[1] == 'i' && opname[2] == '_')) { + call strcpy (opname, Memc[param], SZ_FNAME) + im = IO_IMPTR(IMOP(ex,1)) +getpar_ O_LEN(o) = 0 + switch (imgftype (im, Memc[param])) { + case TY_BOOL: + O_TYPE(o) = TY_BOOL + O_VALI(o) = btoi (imgetb (im, Memc[param])) + case TY_CHAR: + O_TYPE(o) = TY_CHAR + O_LEN(o) = SZ_LINE + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + case TY_INT: + O_TYPE(o) = TY_INT + O_VALI(o) = imgeti (im, Memc[param]) + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + O_VALD(o) = imgetd (im, Memc[param]) + default: + call sprintf (Memc[emsg], SZ_LINE, "param %s not found\n") + call pargstr (Memc[param]) + call error (6, Memc[emsg]) + } + + call sfree (sp) + return + + } else if (IS_LOWER(opname[1]) && opname[3] == '.') { + # This is a tag.param operand. Break out the image tag name and + # get the image pointer for it, then get the parameter + if (opname[1] == 'b') { # band of 3-D image, only 1 ptr + imnum = 1 + } else if (opname[1] == 'i') { # image descriptor + i = 2 + if (ctoi (opname, i, imnum) == 0) + call error (6, "can't parse operand") + } else { + call sprintf (Memc[buf], SZ_LINE, + "Unknown outbands operand `%s'\n") + call pargstr(opname) + call error (1, Memc[buf]) + } + + # Get the parameter value. + im = IO_IMPTR(IMOP(ex,imnum)) + call strcpy (opname[4], Memc[param], SZ_FNAME) + goto getpar_ + } + + nops = EX_NIMOPS(ex) + found = NO + do i = 1, nops { + # Search for operand name which matches requested value. + op = IMOP(ex,i) + if (streq (Memc[IO_TAG(op)],opname)) { + found = YES + break + } + } + + if (VDEBUG && found == YES) { + call eprintf (" tag=%s found=%d ") + call pargstr(Memc[IO_TAG(op)]) ; call pargi(found) + call zze_prop (op) + } + + if (found == YES) { + # Copy operand descriptor to 'o' + #optype = ex_ptype (IO_TYPE(op), IO_NBYTES(op)) + optype = IO_TYPE(op) + switch (optype) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), IO_NPIX(op), TY_SHORT) + call amovs (Mems[IO_DATA(op)], Mems[O_VALP(o)], IO_NPIX(op)) + + case TY_INT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_INT + call malloc (O_VALP(o), IO_NPIX(op), TY_INT) + call amovi (Memi[IO_DATA(op)], Memi[O_VALP(o)], IO_NPIX(op)) + + case TY_LONG: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_LONG + call malloc (O_VALP(o), IO_NPIX(op), TY_LONG) + call amovl (Meml[IO_DATA(op)], Meml[O_VALP(o)], IO_NPIX(op)) + + case TY_REAL: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), IO_NPIX(op), TY_REAL) + call amovr (Memr[IO_DATA(op)], Memr[O_VALP(o)], IO_NPIX(op)) + + case TY_DOUBLE: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_DOUBLE + call malloc (O_VALP(o), IO_NPIX(op), TY_DOUBLE) + call amovd (Memd[IO_DATA(op)], Memd[O_VALP(o)], IO_NPIX(op)) + + } + + } else { + call sprintf (Memc[buf], SZ_LINE, "Unknown outbands operand `%s'\n") + call pargstr(opname) + call error (1, Memc[buf]) + } + + call sfree (sp) +end + + +# EX_OBFCN -- Called by evvexpr to execute import outbands special functions. + +procedure ex_obfcn (ex, fcn, args, nargs, o) + +pointer ex #i package pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf +pointer r, g, b, gray +pointer scaled, data +int i, len, v_nargs, func, nbins +short sz1, sz2, sb1, sb2, zero +real gamma, bscale, bzero, scale, pix +real z1, z2 + +int strdic() +bool fp_equalr(), strne() + +define setop_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, OB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case GRAY, GREY: + v_nargs = 3 + case ZSCALE: + v_nargs = -1 + case BSCALE: + v_nargs = 3 + case GAMMA: + v_nargs = -1 + case BLOCK: + v_nargs = 3 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + if (DEBUG) { + call eprintf ("obfcn: nargs=%d func=%d\n") + call pargi (nargs) ; call pargi (func) + do i = 1, nargs { call eprintf ("\t") ; call zze_pevop (args[i]) } + call flush (STDERR) + } + + # Evaluate the function. + zero = 0 + switch (func) { + case GRAY, GREY: + # evaluate expression for NTSC grayscale. + r = O_VALP(args[1]) + g = O_VALP(args[2]) + b = O_VALP(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + gray = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mems[r+i] + + G_COEFF * Mems[g+i] + + B_COEFF * Mems[b+i] + } + + case TY_INT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memi[r+i] + + G_COEFF * Memi[g+i] + + B_COEFF * Memi[b+i] + } + + case TY_LONG: + do i = 0, len { + Memr[gray+i] = R_COEFF * Meml[r+i] + + G_COEFF * Meml[g+i] + + B_COEFF * Meml[b+i] + } + + case TY_REAL: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memr[r+i] + + G_COEFF * Memr[g+i] + + B_COEFF * Memr[b+i] + } + + case TY_DOUBLE: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memd[r+i] + + G_COEFF * Memd[g+i] + + B_COEFF * Memd[b+i] + } + + } + + case ZSCALE: + data = O_VALP(args[1]) + switch (O_TYPE(args[2])) { + case TY_SHORT: z1 = O_VALS(args[2]) + case TY_INT: z1 = O_VALI(args[2]) + case TY_LONG: z1 = O_VALL(args[2]) + case TY_REAL: z1 = O_VALR(args[2]) + case TY_DOUBLE: z1 = O_VALD(args[2]) + } + switch (O_TYPE(args[3])) { + case TY_SHORT: z2 = O_VALS(args[3]) + case TY_INT: z2 = O_VALI(args[3]) + case TY_LONG: z2 = O_VALL(args[3]) + case TY_REAL: z2 = O_VALR(args[3]) + case TY_DOUBLE: z2 = O_VALD(args[3]) + } + if (nargs < 4) + nbins = 256 + else + nbins = O_VALI(args[4]) + len = O_LEN(args[1]) + O_LEN(o) = len + O_TYPE(o) = O_TYPE(args[1]) + call malloc (O_VALP(o), len, O_TYPE(args[1])) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + sz1 = z1 + sz2 = z2 + sb1 = 0 + sb2 = nbins - 1 + if (abs(sz2-sz1) > 1.0e-5) + call amaps (Mems[data], Mems[scaled], len, sz1, sz2, + sb1, sb2) + else + call amovks (0, Mems[scaled], len) + + case TY_INT: + if (abs(z2-z1) > 1.0e-5) + call amapi (Memi[data], Memi[scaled], len, int (z1), + int(z2), int (0), int (nbins-1)) + else + call amovki (int (0), Memi[scaled], len) + + case TY_LONG: + if (abs(z2-z1) > 1.0e-5) + call amapl (Meml[data], Meml[scaled], len, long (z1), + long(z2), long (0), long (nbins-1)) + else + call amovkl (long (0), Meml[scaled], len) + + case TY_REAL: + if (abs(z2-z1) > 1.0e-5) + call amapr (Memr[data], Memr[scaled], len, real (z1), + real(z2), real (0), real (nbins-1)) + else + call amovkr (real (0), Memr[scaled], len) + + case TY_DOUBLE: + if (abs(z2-z1) > 1.0e-5) + call amapd (Memd[data], Memd[scaled], len, double (z1), + double(z2), double (0), double (nbins-1)) + else + call amovkd (double (0), Memd[scaled], len) + + } + + case BSCALE: + data = O_VALP(args[1]) + bzero = O_VALR(args[2]) + bscale = O_VALR(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Mems[data+i] - bzero) / bscale + } else + call amovks (zero, Mems[scaled], len) + + case TY_INT: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Memi[data+i] - bzero) / bscale + } else + call amovki (int(0), Memi[scaled], len) + + case TY_LONG: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Meml[data+i] - bzero) / bscale + } else + call amovkl (long(0), Meml[scaled], len) + + case TY_REAL: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Memr[data+i] - bzero) / bscale + } else + call amovkr (real(0), Memr[scaled], len) + + case TY_DOUBLE: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Memd[data+i] - bzero) / bscale + } else + call amovkd (double(0), Memd[scaled], len) + + } + + case GAMMA: + data = O_VALP(args[1]) + gamma = 1.0 / O_VALR(args[2]) + if (nargs == 3) + scale = max (1.0, O_VALR(args[3])) + else + scale = 255.0 + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + pix = max (zero, Mems[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + + case TY_INT: + do i = 0, len { + pix = max (int(0), Memi[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + + case TY_LONG: + do i = 0, len { + pix = max (long(0), Meml[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + + case TY_REAL: + do i = 0, len { + pix = max (real(0), Memr[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + + case TY_DOUBLE: + do i = 0, len { + pix = max (double(0), Memd[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + + } + + case BLOCK: + len = O_VALI(args[2]) + O_LEN(o) = len + O_TYPE(o) = O_TYPE(args[1]) + call malloc (O_VALP(o), len, O_TYPE(args[1])) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovks (O_VALS(args[1]), Mems[scaled], len) + case TY_INT: + call amovki (O_VALI(args[1]), Memi[scaled], len) + case TY_LONG: + call amovkl (O_VALL(args[1]), Meml[scaled], len) + case TY_REAL: + call amovkr (O_VALR(args[1]), Memr[scaled], len) + case TY_DOUBLE: + call amovkd (O_VALD(args[1]), Memd[scaled], len) + } + + + } + + if (DEBUG) { call zze_pevop (o) } + + call sfree (sp) +end diff --git a/pkg/dataio/export/generic/exraster.x b/pkg/dataio/export/generic/exraster.x new file mode 100644 index 00000000..9838894f --- /dev/null +++ b/pkg/dataio/export/generic/exraster.x @@ -0,0 +1,709 @@ +include +include +include +include "../export.h" + +define DEBUG false + + +# EX_NO_INTERLEAVE - Write out the image with no interleaving. + +procedure ex_no_interleave (ex) + +pointer ex #i task struct pointer + +pointer op, out +int i, j, k, line, percent, orow +int fd, outtype + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_no_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + # Loop over the number of image expressions. + fd = EX_FD(ex) + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NEXPR(ex) { + + # Process each line in the image. + do j = 1, O_HEIGHT(ex,i) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + #line = EX_NLINES(ex) - j + 1 + line = O_HEIGHT(ex,i) - j + 1 + else + line = j + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,i)) + + # Convert to the output pixel type. + out = ex_chtype (ex, op, outtype) + + # Write evaluated pixels. + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, out, O_LEN(op)) + else { + call ex_listpix (fd, outtype, out, O_LEN(op), j, i, + EX_NEXPR(ex), NO) + } + + # Clean up the pointers. + if (outtype == TY_UBYTE || outtype == TY_CHAR) + call mfree (out, TY_CHAR) + else + call mfree (out, outtype) + call evvfree (op) + do k = 1, EX_NIMOPS(ex) { + op = IMOP(ex,k) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + } + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_LN_INTERLEAVE - Write out the image with line interleaving. + +procedure ex_ln_interleave (ex) + +pointer ex #i task struct pointer + +pointer op, out +int i, j, line, percent, orow +int fd, outtype + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_ln_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + # Process each line in the image. + fd = EX_FD(ex) + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NLINES(ex) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - i + 1 + else + line = i + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Loop over the number of image expressions. + do j = 1, EX_NEXPR(ex) { + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,j)) + + # Convert to the output pixel type. + out = ex_chtype (ex, op, outtype) + + # Write evaluated pixels. + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, out, O_LEN(op)) + else { + call ex_listpix (fd, outtype, out, O_LEN(op), i, j, + EX_NEXPR(ex), NO) + } + + # Clean up the pointers. + if (outtype == TY_UBYTE || outtype == TY_CHAR) + call mfree (out, TY_CHAR) + else + call mfree (out, outtype) + call evvfree (op) + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + + do j = 1, EX_NIMOPS(ex) { + op = IMOP(ex,j) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + } + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_PX_INTERLEAVE - Write out the image with pixel interleaving. + +procedure ex_px_interleave (ex) + +pointer ex #i task struct pointer + +pointer sp, pp, op +pointer o, outptr +int i, j, line, npix, outtype +long totpix +int fd, percent, orow + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_px_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + call smark (sp) + call salloc (pp, EX_NEXPR(ex), TY_POINTER) + + # Process each line in the image. + fd = EX_FD(ex) + outptr = NULL + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NLINES(ex) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - i + 1 + else + line = i + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Loop over the number of image expressions. + totpix = 0 + do j = 1, EX_NEXPR(ex) { + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,j)) + + # Convert to the output pixel type. + o = ex_chtype (ex, op, outtype) + Memi[pp+j-1] = o + + npix = O_LEN(op) + #npix = EX_OCOLS(op) + call evvfree (op) + } + + # Merge pixels into a single vector. + call ex_merge_pixels (Memi[pp], EX_NEXPR(ex), npix, outtype, + outptr, totpix) + + # Write vector of merged pixels. + if (outtype == TY_UBYTE) + call achtsb (Memc[outptr], Memc[outptr], totpix) + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, outptr, totpix) + else { + call ex_listpix (fd, outtype, outptr, totpix, + i, EX_NEXPR(ex), EX_NEXPR(ex), YES) + } + + if (outtype != TY_CHAR && outtype != TY_UBYTE) + call mfree (outptr, outtype) + else + call mfree (outptr, TY_CHAR) + do j = 1, EX_NIMOPS(ex) { + op = IMOP(ex,j) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + do j = 1, EX_NEXPR(ex) { + if (outtype != TY_CHAR && outtype != TY_UBYTE) + call mfree (Memi[pp+j-1], outtype) + else + call mfree (Memi[pp+j-1], TY_CHAR) + } + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + + call sfree (sp) + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_GETPIX - Get the pixels from the image and load each operand. + +procedure ex_getpix (ex, line) + +pointer ex #i task struct pointer +int line #i current line number + +pointer im, op, data +int nptrs, i, band + +pointer imgl3s(), imgl3i(), imgl3l() +pointer imgl3r(), imgl3d() + +begin + # Loop over each of the image operands. + nptrs = EX_NIMOPS(ex) + do i = 1, nptrs { + op = IMOP(ex,i) + im = IO_IMPTR(op) + band = max (1, IO_BAND(op)) + + if (line > IM_LEN(im,2)) { + call calloc (IO_DATA(op), IM_LEN(im,1), IM_PIXTYPE(im)) + IO_ISIM(op) = NO + IO_NPIX(op) = IM_LEN(im,1) + next + } else if (IO_DATA(op) == NULL) + call malloc (IO_DATA(op), IM_LEN(im,1), IM_PIXTYPE(im)) + + switch (IM_PIXTYPE(im)) { + case TY_USHORT: + data = imgl3s (im, line, band) + call amovs (Mems[data], Mems[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_SHORT + IO_NBYTES(op) = SZ_SHORT * SZB_CHAR + IO_ISIM(op) = YES + + case TY_SHORT: + data = imgl3s (im, line, band) + call amovs (Mems[data], Mems[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_SHORT + IO_NBYTES(op) = SZ_SHORT * SZB_CHAR + IO_ISIM(op) = YES + + case TY_INT: + data = imgl3i (im, line, band) + call amovi (Memi[data], Memi[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_INT + IO_NBYTES(op) = SZ_INT32 * SZB_CHAR + IO_ISIM(op) = YES + + case TY_LONG: + data = imgl3l (im, line, band) + call amovl (Meml[data], Meml[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_LONG + IO_NBYTES(op) = SZ_LONG * SZB_CHAR + IO_ISIM(op) = YES + + case TY_REAL: + data = imgl3r (im, line, band) + call amovr (Memr[data], Memr[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_REAL + IO_NBYTES(op) = SZ_REAL * SZB_CHAR + IO_ISIM(op) = YES + + case TY_DOUBLE: + data = imgl3d (im, line, band) + call amovd (Memd[data], Memd[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_DOUBLE + IO_NBYTES(op) = SZ_DOUBLE * SZB_CHAR + IO_ISIM(op) = YES + + } + IO_NPIX(op) = IM_LEN(im,1) + } +end + + +# EX_WPIXELS - Write the pixels to the current file. + +procedure ex_wpixels (fd, otype, pix, npix) + +int fd #i output file descriptor +int otype #i output data type +pointer pix #i pointer to pixel data +int npix #i number of pixels to write + +begin + # Write binary output. + switch (otype) { + case TY_UBYTE: + call write (fd, Mems[pix], npix / SZB_CHAR) + case TY_USHORT: + call write (fd, Mems[pix], npix * SZ_SHORT/SZ_CHAR) + + case TY_SHORT: + call write (fd, Mems[pix], npix * SZ_SHORT/SZ_CHAR) + + case TY_INT: + if (SZ_INT != SZ_INT32) + call ipak32 (Memi[pix], Memi[pix], npix) + call write (fd, Memi[pix], npix * SZ_INT32/SZ_CHAR) + + case TY_LONG: + call write (fd, Meml[pix], npix * SZ_LONG/SZ_CHAR) + + case TY_REAL: + call write (fd, Memr[pix], npix * SZ_REAL/SZ_CHAR) + + case TY_DOUBLE: + call write (fd, Memd[pix], npix * SZ_DOUBLE/SZ_CHAR) + + } +end + + +# EX_LISTPIX - Write the pixels to the current file as ASCII text. + +procedure ex_listpix (fd, type, data, npix, line, band, nbands, merged) + +int fd #i output file descriptor +int type #i output data type +pointer data #i pointer to pixel data +int npix #i number of pixels to write +int line #i current output line number +int band #i current output band number +int nbands #i no. of output bands +int merged #i are pixels interleaved? + +int i, j, k +int val, pix, shifti(), andi() + +begin + if (merged == YES && nbands > 1) { + do i = 1, npix { + k = 0 + do j = 1, nbands { + call fprintf (fd, "%4d %4d %4d ") + call pargi (i) + call pargi (line) + call pargi (j) + + switch (type) { + case TY_UBYTE: + val = Memc[data+k] + if (mod(i,2) == 1) { + pix = shifti (val, -8) + } else { + pix = andi (val, 000FFX) + k = k + 1 + } + if (pix < 0) pix = pix + 256 + call fprintf (fd, "%d\n") + call pargi (pix) + case TY_CHAR, TY_SHORT, TY_USHORT: + call fprintf (fd, "%d\n") + call pargs (Mems[data+((j-1)*npix+i)-1]) + case TY_INT: + call fprintf (fd, "%d\n") + call pargi (Memi[data+((j-1)*npix+i)-1]) + case TY_LONG: + call fprintf (fd, "%d\n") + call pargl (Meml[data+((j-1)*npix+i)-1]) + case TY_REAL: + call fprintf (fd, "%g\n") + call pargr (Memr[data+((j-1)*npix+i)-1]) + case TY_DOUBLE: + call fprintf (fd, "%g\n") + call pargd (Memd[data+((j-1)*npix+i)-1]) + } + } + } + } else { + j = 0 + do i = 1, npix { + if (nbands > 1) { + call fprintf (fd, "%4d %4d %4d ") + call pargi (i) + call pargi (line) + call pargi (band) + } else { + call fprintf (fd, "%4d %4d ") + call pargi (i) + call pargi (line) + } + + switch (type) { + case TY_UBYTE: + val = Memc[data+j] + if (mod(i,2) == 1) { + pix = shifti (val, -8) + } else { + pix = andi (val, 000FFX) + j = j + 1 + } + if (pix < 0) pix = pix + 256 + call fprintf (fd, "%d\n") + call pargi (pix) + case TY_CHAR, TY_SHORT, TY_USHORT: + call fprintf (fd, "%d\n") + call pargs (Mems[data+i-1]) + case TY_INT: + call fprintf (fd, "%d\n") + call pargi (Memi[data+i-1]) + case TY_LONG: + call fprintf (fd, "%d\n") + call pargl (Meml[data+i-1]) + case TY_REAL: + call fprintf (fd, "%g\n") + call pargr (Memr[data+i-1]) + case TY_DOUBLE: + call fprintf (fd, "%g\n") + call pargd (Memd[data+i-1]) + } + } + } +end + + +# EX_MERGE_PIXELS - Merge a group of pixels arrays into one array by combining +# the elements. Returns an allocated pointer which must be later freed and +# the total number of pixels. + +procedure ex_merge_pixels (ptrs, nptrs, npix, dtype, pix, totpix) + +pointer ptrs[ARB] #i array of pixel ptrs +int nptrs #i number of ptrs +int npix #i no. of pixels in each array +int dtype #i type of pointer to alloc +pointer pix #o output pixel array ptr +int totpix #o total no. of output pixels + +int i, j, ip + +begin + # Calculate the number of output pixels and allocate the pointer. + totpix = nptrs * npix + if (dtype != TY_CHAR && dtype != TY_UBYTE) + call realloc (pix, totpix, dtype) + else { + call realloc (pix, totpix, TY_CHAR) + do i = 1, nptrs + call achtbs (Mems[ptrs[i]], Mems[ptrs[i]], npix) + } + + # Fill the output array + ip = 0 + for (i = 1; i<=npix; i=i+1) { + do j = 1, nptrs { + switch (dtype) { + case TY_UBYTE: + Mems[pix+ip] = Mems[ptrs[j]+i-1] + case TY_USHORT: + Mems[pix+ip] = Mems[ptrs[j]+i-1] + + case TY_SHORT: + Mems[pix+ip] = Mems[ptrs[j]+i-1] + + case TY_INT: + Memi[pix+ip] = Memi[ptrs[j]+i-1] + + case TY_LONG: + Meml[pix+ip] = Meml[ptrs[j]+i-1] + + case TY_REAL: + Memr[pix+ip] = Memr[ptrs[j]+i-1] + + case TY_DOUBLE: + Memd[pix+ip] = Memd[ptrs[j]+i-1] + + } + + ip = ip + 1 + } + } +end + + +# EX_CHTYPE - Change the expression operand vector to the output datatype. +# We allocate and return a pointer to the correct type to the converted +# pixels, this pointer must be freed later on. Any IEEE or byte-swapping +# requests are also handled here. + +pointer procedure ex_chtype (ex, op, type) + +pointer ex #i task struct pointer +pointer op #i evvexpr operand pointer +int type #i new type of pointer + +pointer out, coerce() +int swap, flags + +begin + # Allocate the pointer and coerce it so the routine works. + if (type == TY_UBYTE || type == TY_CHAR) + call calloc (out, O_LEN(op), TY_CHAR) + else { + call calloc (out, O_LEN(op), type) + out = coerce (out, type, TY_CHAR) + } + + # If this is a color index image subtract one from the pixel value + # to get the index. + if (bitset (flags, OF_CMAP)) + call ex_pix_to_index (O_VALP(op), O_TYPE(op), O_LEN(op)) + + # Change the pixel type. + flags = EX_OUTFLAGS(ex) + swap = EX_BSWAP(ex) + switch (O_TYPE(op)) { + case TY_CHAR: + call achtc (Memc[O_VALP(op)], Memc[out], O_LEN(op), type) + + case TY_SHORT: + call achts (Mems[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I2) || bitset (swap, S_ALL)) + call bswap4 (Mems[out], 1, Mems[out], 1, O_LEN(op)) + + case TY_INT: + call achti (Memi[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I4) || bitset (swap, S_ALL)) + call bswap4 (Memi[out], 1, Memi[out], 1, O_LEN(op)) + + case TY_LONG: + call achtl (Meml[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I4) || bitset (swap, S_ALL)) + call bswap4 (Meml[out], 1, Meml[out], 1, O_LEN(op)) + + case TY_REAL: + call achtr (Memr[O_VALP(op)], Memc[out], O_LEN(op), type) + + # See if we need to convert to IEEE + if (bitset (flags, OF_IEEE) && IEEE_USED == NO) + call ieevpakr (Memr[out], Memr[out], O_LEN(op)) + + case TY_DOUBLE: + call achtd (Memd[O_VALP(op)], Memc[out], O_LEN(op), type) + + # See if we need to convert to IEEE + if (bitset (flags, OF_IEEE) && IEEE_USED == NO) + call ieevpakd (Memd[P2D(out)], Memd[P2D(out)], O_LEN(op)) + + default: + call error (0, "Invalid output type requested.") + } + + if (type != TY_UBYTE && type != TY_CHAR) + out = coerce (out, TY_CHAR, type) + return (out) +end + + +# EX_PIX_TO_INDEX - Convert pixel values to color index values. We assume +# the colormap has at most 256 entries. + +procedure ex_pix_to_index (ptr, type, len) + +pointer ptr #i data ptr +int type #i data type of array +int len #i length of array + + +short sindx, smin, smax + +int iindx, imin, imax + +long lindx, lmin, lmax + +real rindx, rmin, rmax + +double dindx, dmin, dmax + + +begin + + sindx = short (1) + smin = short (0) + smax = short (255) + + iindx = int (1) + imin = int (0) + imax = int (255) + + lindx = long (1) + lmin = long (0) + lmax = long (255) + + rindx = real (1) + rmin = real (0) + rmax = real (255) + + dindx = double (1) + dmin = double (0) + dmax = double (255) + + + switch (type) { + + case TY_SHORT: + call asubks (Mems[ptr], sindx, Mems[ptr], len) + call amaxks (Mems[ptr], smin, Mems[ptr], len) + call aminks (Mems[ptr], smax, Mems[ptr], len) + + case TY_INT: + call asubki (Memi[ptr], iindx, Memi[ptr], len) + call amaxki (Memi[ptr], imin, Memi[ptr], len) + call aminki (Memi[ptr], imax, Memi[ptr], len) + + case TY_LONG: + call asubkl (Meml[ptr], lindx, Meml[ptr], len) + call amaxkl (Meml[ptr], lmin, Meml[ptr], len) + call aminkl (Meml[ptr], lmax, Meml[ptr], len) + + case TY_REAL: + call asubkr (Memr[ptr], rindx, Memr[ptr], len) + call amaxkr (Memr[ptr], rmin, Memr[ptr], len) + call aminkr (Memr[ptr], rmax, Memr[ptr], len) + + case TY_DOUBLE: + call asubkd (Memd[ptr], dindx, Memd[ptr], len) + call amaxkd (Memd[ptr], dmin, Memd[ptr], len) + call aminkd (Memd[ptr], dmax, Memd[ptr], len) + + } +end + + +# EX_PSTAT - Print information about the progress we're making. + +procedure ex_pstat (ex, row, percent) + +pointer ex #i task struct pointer +int row #u current row +int percent #u percent completed + +begin + # Print percent done if being verbose + if (row * 100 / EX_OROWS(ex) >= percent + 10) { + percent = percent + 10 + call eprintf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDERR) + } +end diff --git a/pkg/dataio/export/generic/mkpkg b/pkg/dataio/export/generic/mkpkg new file mode 100644 index 00000000..4902710d --- /dev/null +++ b/pkg/dataio/export/generic/mkpkg @@ -0,0 +1,12 @@ +# Compile the generic sources. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + exobands.x ../exfcn.h ../export.h \ + + exraster.x ../export.h + ; diff --git a/pkg/dataio/export/mkpkg b/pkg/dataio/export/mkpkg new file mode 100644 index 00000000..986450a7 --- /dev/null +++ b/pkg/dataio/export/mkpkg @@ -0,0 +1,36 @@ +# MKPKG file for the EXPORT task + +$call update +$exit + +update: + $checkout libpkg.a ../ + $update libpkg.a + $checkin libpkg.a ../ + ; + +generic: + $set GEN = "$$generic -k" + $ifolder (generic/exobands.x, exobands.gx) + $(GEN) exobands.gx -o generic/exobands.x $endif + $ifolder (generic/exraster.x, exraster.gx) + $(GEN) exraster.gx -o generic/exraster.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + @generic # compile the generic format code + @bltins # compile the builtin format code + + exbltins.x exbltins.h export.h + excmap.x cmaps.inc export.h + exhdr.x export.h \ + + expreproc.x exfcn.h cmaps.inc export.h + exrgb8.x export.h + exzscale.x export.h + t_export.x export.h \ + + zzedbg.x exbltins.h export.h + ; diff --git a/pkg/dataio/export/t_export.x b/pkg/dataio/export/t_export.x new file mode 100644 index 00000000..6516ed11 --- /dev/null +++ b/pkg/dataio/export/t_export.x @@ -0,0 +1,1160 @@ +include +include +include +include +include +include +include "export.h" + +define DEBUG false + + +# T_EXPORT -- Task entry. Convert one or more IRAF image to an output binary +# file. Output may be a raw binary raster, with or without header information, +# a pixel listing, or a specified (supported) format. Arbitrary expressions +# may be applied to the input images before conversion. + +procedure t_export () + +pointer ex # task struct pointer +pointer sp, blist, bfname # stack pointers +pointer imname[MAX_OPERANDS] +pointer imlist # image list pointer +pointer im # image descriptor +int binlist # binary file list pointer +int imdim # dimensionality of images +int imtype # datatype of images +int i + +pointer ex_init(), immap() +int ex_getpars() +int clgfil(), access(), fntopnb() +int imtlen(), imtopenp(), open(), imtgetim() +bool streq() + +errchk open, immap, ex_chkimlist + +define quit_ 99 + +begin + # Allocate local stack storage. + call smark (sp) + call salloc (bfname, SZ_FNAME, TY_CHAR) + call salloc (blist, SZ_FNAME, TY_CHAR) + call aclrc (Memc[blist], SZ_FNAME) + call aclrc (Memc[bfname], SZ_FNAME) + do i = 1, MAX_OPERANDS { + call salloc (imname[i], SZ_FNAME, TY_CHAR) + call aclrc (Memc[imname[i]], SZ_FNAME) + } + + # Get the image and file lists. + imlist = imtopenp ("images") + call clgstr ("binfiles", Memc[blist], SZ_FNAME) + if (!streq("", Memc[blist]) && !streq(" ", Memc[blist])) { + binlist = fntopnb (Memc[blist], YES) + iferr (call ex_chkimlist (imlist, binlist, imdim, imtype)) { + call imtclose (imlist) + call clpcls (binlist) + call sfree (sp) + call erract (EA_FATAL) + } + call clprew (binlist) + } else { + binlist = -1 + iferr (call ex_chkimlist (imlist, binlist, imdim, imtype)) { + call imtclose (imlist) + call sfree (sp) + call erract (EA_FATAL) + } + } + call imtrew (imlist) # rewind the list ptrs + + # Allocate structure and get the task parameters. + ex = ex_init () + EX_IMDIM(ex) = imdim + EX_IMTYPE(ex) = imtype + if (ex_getpars (ex) != OK) + goto quit_ + + # Do some last minute error checking. + if (imtlen(imlist) < EX_NIMAGES(ex)) + call error (0, "Too many image operands in expression list") + + # Start processing the files. + repeat { + + # Open the output binary file. + if (binlist > 0) { + if (clgfil(binlist, Memc[bfname], SZ_FNAME) == EOF) + break + + # If this is a builtin format append the format suffix if it's + # not already there and then open the file. + call ex_mkfname (ex, Memc[bfname]) + if (access (BFNAME(ex), 0, 0) == YES) { + call eprintf ("Output file `%s' already exists.\n") + call pargstr (BFNAME(ex)) + goto quit_ + } + if (EX_FORMAT(ex) != FMT_LIST) + EX_FD(ex) = open (BFNAME(ex), NEW_FILE, BINARY_FILE) + else + EX_FD(ex) = open (BFNAME(ex), NEW_FILE, TEXT_FILE) + } else { + call strcpy ("STDOUT", Memc[bfname], SZ_FNAME) + call strcpy ("STDOUT", BFNAME(ex), SZ_FNAME) + EX_FD(ex) = STDOUT + } + + # Open the image pointers. If no outbands expressions were given + # we're converting only one image, but we need to fake up the + # image operands. + if (EX_NIMAGES(ex) == EX_UNDEFINED) { + i = imtgetim(imlist, Memc[imname[1]], SZ_FNAME) + im = immap (Memc[imname[1]], READ_ONLY, 0) + EX_NIMAGES(ex) = 1 + EX_NEXPR(ex) = max (1, IM_LEN(im,3)) + EX_NCOLS(ex) = IM_LEN(im,1) + EX_NLINES(ex) = IM_LEN(im,2) + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), BAND_STORAGE) + if (EX_IMDIM(ex) == 0) + EX_IMDIM(ex) = IM_NDIM(im) + if (EX_IMTYPE(ex) == 0) { + EX_IMTYPE(ex) = IM_PIXTYPE(im) + EX_OUTTYPE(ex) = IM_PIXTYPE(im) + } + + # Fake the expressions and break out the operands. + do i = 1, EX_NEXPR(ex) { + call ex_alloc_outbands (OBANDS(ex,i)) + call sprintf (O_EXPR(ex,i), SZ_LINE, "b%d") + call pargi (i) + } + call ex_parse_operands (ex) + if (EX_NEXPR(ex) > 1) { + EX_OUTFLAGS(ex) = and (EX_OUTFLAGS(ex), not(BAND_STORAGE)) + EX_OUTFLAGS(ex) = and (EX_OUTFLAGS(ex), not(LINE_STORAGE)) + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), PIXEL_STORAGE) + } + IO_IMPTR(IMOP(ex,1)) = im + + # Print some status stuff so we know what's being converted. + call eprintf ("%s -> %s\n") + call pargstr (Memc[imname[1]]) + call pargstr (BFNAME(ex)) + } else { + EX_NLINES(ex) = 0 + do i = 1, EX_NIMAGES(ex) { + if (imtgetim(imlist, Memc[imname[i]], SZ_FNAME) == EOF) + call error (1, "Short image list") + im = immap (Memc[imname[i]], READ_ONLY, 0) + EX_NCOLS(ex) = IM_LEN(im,1) + EX_NLINES(ex) = max (EX_NLINES(ex), IM_LEN(im,2)) + IO_IMPTR(IMOP(ex,i)) = im + if (EX_IMDIM(ex) == 0) + EX_IMDIM(ex) = IM_NDIM(im) + if (EX_IMTYPE(ex) == 0) { + EX_IMTYPE(ex) = IM_PIXTYPE(im) + EX_OUTTYPE(ex) = IM_PIXTYPE(im) + } + + # Print some status stuff so we know what's being converted. + call eprintf ("%s") + call pargstr (Memc[imname[i]]) + if (i < EX_NIMAGES(ex)) + call eprintf (",") + else { + call eprintf (" -> %s\n") + call pargstr (BFNAME(ex)) + } + call flush (STDERR) + } + } + + # For 3-D data we only have one image, but we may have multiple + # image operands (bands) within the image. If this is the case + # then copy the image pointer to the remaining operand structs. + if (EX_NIMAGES(ex) == 1 && EX_NIMOPS(ex) > 1) { + do i = 2, EX_NIMOPS(ex) + IO_IMPTR(IMOP(ex,i)) = IO_IMPTR(IMOP(ex,1)) + } + + # Now patch up any zscale calls in the expression string. + do i = 1, EX_NEXPR(ex) + call ex_patch_zscale (ex, i) + + # Now that we have all the image information and things are going + # well, compute the size of the output image. + call ex_outsize (ex) + + # If we're being verbose the print some more information on the + # input images and output file. + if (EX_VERBOSE(ex) == YES) + call ex_prinfo (ex, imname) + + # Write the header now if this is a generic raster. + if (EX_HEADER(ex) != HDR_NONE && EX_FORMAT(ex) != FMT_BUILTIN) + call ex_wheader (ex, Memc[bfname]) + + # Process the image. + call ex_process_image (ex) + + # Unmap the image pointer(s). + do i = 1, EX_NIMAGES(ex) { + im = IO_IMPTR(IMOP(ex,i)) + if (im != NULL) + call imunmap (im) + } + + # Close the output file descriptor. + if (EX_FD(ex) != NULL) + call close (EX_FD(ex)) + + # If we created a temp image then delete that now. + if (EX_TIMPTR(ex) != NULL) + call imdelete (TIMNAME(ex)) + + if (binlist < 0) + break + } + + # Clean up. +quit_ call imtclose (imlist) + if (binlist > 0) + call clpcls (binlist) + call sfree (sp) +end + + +# EX_INIT - Initialize the export task structure. + +pointer procedure ex_init () + +pointer ex + +begin + # Allocate the task structure pointer. + iferr (call calloc (ex, SZ_EXPSTRUCT, TY_STRUCT)) + call error (0, "Error allocating EXPORT task structure.") + + # Allocate internal pointers. + call calloc (EX_HDRPTR(ex), SZ_FNAME, TY_CHAR) + call calloc (EX_CMPTR(ex), SZ_FNAME, TY_CHAR) + call calloc (EX_LUTPTR(ex), SZ_FNAME, TY_CHAR) + call calloc (EX_BFNPTR(ex), SZ_FNAME, TY_CHAR) + call calloc (EX_OBANDS(ex), MAX_OBEXPR, TY_STRUCT) + call calloc (EX_IMOPS(ex), MAX_OPERANDS, TY_STRUCT) + call calloc (EX_OTPTR(ex), SZ_LINE, TY_CHAR) + call calloc (EX_OBPTR(ex), SZ_EXPSTR, TY_CHAR) + + # Initialize some parameters. + EX_OUTFLAGS(ex) = NULL + EX_NLUTEL(ex) = INDEFI + EX_NCOLORS(ex) = CMAP_SIZE + EX_PSDPI(ex) = EPS_DPI + EX_PSSCALE(ex) = EPS_SCALE + EX_BRIGHTNESS(ex) = 0.5 + EX_CONTRAST(ex) = 1.0 + + return (ex) +end + + +# EX_FREE - Free the export task structure. + +procedure ex_free (ex) + +pointer ex #i task struct pointer + +int i + +begin + # Free internal pointers. + call mfree (EX_HDRPTR(ex), TY_CHAR) + call mfree (EX_CMPTR(ex), TY_CHAR) + call mfree (EX_LUTPTR(ex), TY_CHAR) + call mfree (EX_BFNPTR(ex), TY_CHAR) + call mfree (EX_TIMPTR(ex), TY_CHAR) + call mfree (EX_OTPTR(ex), TY_CHAR) + call mfree (EX_OBPTR(ex), TY_CHAR) + + # Free outbands pointers. + for (i=1; i < MAX_OBEXPR; i=i+1) + call ex_free_outbands (OBANDS(ex,i)) + call mfree (EX_OBANDS(ex), TY_POINTER) + + # Free operand pointers. + for (i=1; i < MAX_OPERANDS; i=i+1) + call ex_free_operand (IMOP(ex,i)) + call mfree (EX_IMOPS(ex), TY_POINTER) + + # Free the colormap. + if (EX_CMAP(ex) != NULL) + call mfree (EX_CMAP(ex), TY_CHAR) + + call mfree (ex, TY_STRUCT) +end + + +# EX_GETPARS - Get the task parameters. + +int procedure ex_getpars (ex) + +pointer ex #i task struct pointer + +pointer sp, format, header, bswap +pointer outtype, outbands + +int ex_chkpars(), clgeti(), btoi() +bool clgetb() + +errchk ex_do_format, ex_do_header, ex_do_bswap +errchk ex_do_outtype, ex_do_outbands + +begin + call smark (sp) + call salloc (format, SZ_FNAME, TY_CHAR) + call salloc (header, SZ_FNAME, TY_CHAR) + call salloc (bswap, SZ_FNAME, TY_CHAR) + call salloc (outtype, SZ_LINE, TY_CHAR) + call salloc (outbands, SZ_EXPSTR, TY_CHAR) + + call aclrc (Memc[format], SZ_FNAME) + call aclrc (Memc[header], SZ_FNAME) + call aclrc (Memc[bswap], SZ_FNAME) + call aclrc (Memc[outtype], SZ_FNAME) + call aclrc (Memc[outbands], SZ_EXPSTR) + + # Get the string valued parameters. + call clgstr ("format", Memc[format], SZ_FNAME) + call clgstr ("header", Memc[header], SZ_FNAME) + call clgstr ("bswap", Memc[bswap], SZ_FNAME) + call clgstr ("outtype", Memc[outtype], SZ_LINE) + call strcpy (Memc[outtype], Memc[EX_OTPTR(ex)], SZ_LINE) + call clgstr ("outbands", Memc[outbands], SZ_EXPSTR) + call strcpy (Memc[outbands], Memc[EX_OBPTR(ex)], SZ_EXPSTR) + + # Get the simple params. + EX_INTERLEAVE(ex) = clgeti ("interleave") + EX_VERBOSE(ex) = btoi (clgetb ("verbose")) + + # Process the parameter values, due error checking + iferr { + call ex_do_format (ex, Memc[format]) + call ex_do_header (ex, Memc[header]) + call ex_do_bswap (ex, Memc[bswap]) + call ex_do_outtype (ex, Memc[outtype]) + call ex_do_outbands(ex, Memc[outbands]) + } then { + call sfree (sp) + call erract (EA_FATAL) + } + + call sfree (sp) + + if (DEBUG) { + call eprintf("ex_format=%d\n"); call pargi (EX_FORMAT(ex)) + call eprintf("ex_bswap=%d\n"); call pargi (EX_BSWAP(ex)) + call eprintf("ex_outtype=%d\n"); call pargi (EX_OUTTYPE(ex)) + call eprintf("ex_header=%d\n"); call pargi (EX_HEADER(ex)) + } + + # Do a sanity check on the params so we can exit now if needed. + return (ex_chkpars (ex)) +end + + +# EX_CHKPARS - Check task parameters to be sure we have a valid conversion. + +int procedure ex_chkpars (ex) + +pointer ex #i task struct pointer + +int flags, exb_chkpars() + +begin + flags = EX_OUTFLAGS(ex) + if (EX_FORMAT(ex) == FMT_BUILTIN && !bitset(EX_OUTFLAGS(ex),OF_MKCMAP)){ + return (exb_chkpars(ex)) + } else { + if (bitset (flags, OF_CMAP)) { + call error (1, "Colormap creation not supported for raw output") + return (ERR) + } + } + + return (OK) +end + + +# EX_CHKIMLIST - Check the image list to be sure it's valid. + +procedure ex_chkimlist (images, files, ndim, type) + +int images #i image list pointer +int files #i binary files list pointer +int ndim #o dimensionality of images +int type #o datatype of images + +pointer im, sp, imname +int dim + +pointer immap() +int imtlen(), imtgetim(), clplen() + +errchk immap + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call aclrc (Memc[imname], SZ_FNAME) + + # Get dimension of first image. + if (imtgetim (images, Memc[imname], SZ_FNAME) != EOF) { + im = immap (Memc[imname], READ_ONLY, 0) + ndim = IM_NDIM(im) + type = IM_PIXTYPE(im) + call imunmap (im) + } else + call error (0, "Unexpected EOF in image list.\n") + + # Loop over remaining images in the list. + while (imtgetim (images, Memc[imname], SZ_FNAME) != EOF) { + im = immap (Memc[imname], READ_ONLY, 0) + dim = IM_NDIM(im) + call imunmap (im) + if (dim != ndim) + call error (0, "Images must all be the same dimension.\n") + } + + if (files > 0) { + if (ndim == 3 && (imtlen (images) != clplen (files))) + call error (0, "No. of images must equal no. of output files\n") + } + + call sfree (sp) +end + + +# EX_OUTSIZE - Compute the output file dimensions. We don't require that +# the expressions all evaluate to same length so we'll patch up the expr +# string to pad with zeroes to the maximum width. + +procedure ex_outsize (ex) + +pointer ex #i task struct pointer + +pointer sp, expr +int i, ip, imnum, plev +int height, maxlen, maxhgt +char ch + +pointer op, ex_evaluate() +int ctoi(), strncmp() + +begin + call smark (sp) + call salloc (expr, SZ_EXPSTR, TY_CHAR) + call aclrc (Memc[expr], SZ_EXPSTR) + + call ex_getpix (ex, 1) + maxlen = 0 + do i = 1, EX_NEXPR(ex) { # get length of each expr + op = ex_evaluate (ex, O_EXPR(ex,i)) + O_WIDTH(ex,i) = O_LEN(op) + maxlen = max (maxlen, O_WIDTH(ex,i)) + call evvfree (op) + } + + do i = 1, EX_NEXPR(ex) { # patch expressions + + if (O_WIDTH(ex,i) <= 1) { + # If the width is 1 we have a constant, meaning we only want + # one line on output and need to pad the constant. + O_HEIGHT(ex,i) = 1 + O_WIDTH(ex,i) = maxlen + call aclrc (Memc[expr], SZ_EXPSTR) + call sprintf (Memc[expr], SZ_EXPSTR, "repl(%s,%d)") + call pargstr (O_EXPR(ex,i)) + call pargi (maxlen) + call strcpy (Memc[expr], O_EXPR(ex,i), SZ_EXPSTR) + + } else if (O_WIDTH(ex,i) <= maxlen) { + # If this is a vector expression then look for image operands. + # The 'height' of the expression will be the largest height + # of the found operands. + + ip = 1 + maxhgt = 1 + call strcpy (O_EXPR(ex,i), Memc[expr], SZ_EXPSTR) + repeat { + while (Memc[expr+ip-1] != 'i' && Memc[expr+ip-1] != 'b' && + Memc[expr+ip-1] != EOS) + ip = ip + 1 + if (Memc[expr+ip-1] == EOS) + break + if (IS_DIGIT(Memc[expr+ip])) { + ip = ip + 1 + if (ctoi (Memc[expr], ip, imnum) == 0) + call error (4, "ex_outsize: can't parse operand") + maxhgt = max (maxhgt,IM_LEN(IO_IMPTR(IMOP(ex,imnum)),2)) + + } else if (strncmp(Memc[expr+ip-1], "block", 5) == 0) { + ip = ip + 1 + + # This is a "block" function call to fill a vertical + # area. The syntax is "block(constant, width, height)" + # so get the height argument. + while (Memc[expr+ip] != '(') + ip = ip + 1 + plev = 0 + repeat { # skip over 1st arg + ip = ip + 1 + ch = Memc[expr+ip] + if (ch == '(') plev = plev + 1 + if (ch == ')') plev = plev - 1 + if (ch == ',' && plev == 0) + break + } + # Should be the start of arg2. + ip = ip + 2 # should be the width + if (ctoi (Memc[expr], ip, height) == 0) + call error (4, "ex_outsize: block() syntax error") + ip = ip + 1 # should be the height + if (ctoi (Memc[expr], ip, height) == 0) + call error (4, "ex_outsize: block() syntax error") + + maxhgt = max (maxhgt, height) + } else + ip = ip + 1 + } + O_HEIGHT(ex,i) = maxhgt + + if (O_WIDTH(ex,i) < maxlen) { + call aclrc (Memc[expr], SZ_EXPSTR) + call sprintf (Memc[expr], SZ_EXPSTR, "%s//repl(0,%d)") + call pargstr (O_EXPR(ex,i)) + call pargi (maxlen - O_WIDTH(ex,i)) + call strcpy (Memc[expr], O_EXPR(ex,i), SZ_EXPSTR) + O_WIDTH(ex,i) = maxlen + } + } + + if (DEBUG) { call eprintf ("%d: len=%d maxlen=%d height=%d\n") + call pargi(i) ; call pargi(O_WIDTH(ex,i)) + call pargi(maxlen) ; call pargi (O_HEIGHT(ex,i)) } + + } + EX_OCOLS(ex) = maxlen + + # Now compute the total number of rows. + if (EX_IMDIM(ex) == 3) { + if (!bitset (EX_OUTFLAGS(ex), PIXEL_STORAGE)) { + if (EX_NEXPR(ex) > 1 && bitset (EX_OUTFLAGS(ex), OF_BAND)) + EX_OROWS(ex) = IM_LEN(IO_IMPTR(IMOP(ex,1)),3)*EX_NLINES(ex) + else + EX_OROWS(ex) = EX_NLINES(ex) + } else + EX_OROWS(ex) = EX_NLINES(ex) + } else if (bitset (EX_OUTFLAGS(ex), OF_BAND)) { + EX_OROWS(ex) = 0 + do i = 1, EX_NEXPR(ex) + EX_OROWS(ex) = EX_OROWS(ex) + O_HEIGHT(ex,i) + } else + EX_OROWS(ex) = EX_NLINES(ex) + + call sfree (sp) +end + + +# EX_DO_FORMAT - Get the task format parameter and set appropriate flags. + +procedure ex_do_format (ex, format) + +pointer ex #i task struct pointer +char format[ARB] #i format parameter value + +bool streq() + +begin + if (DEBUG) { call eprintf("format='%s'\n");call pargstr (format) } + + EX_COLOR(ex) = NO + if (streq(format,"raw")) + EX_FORMAT(ex) = FMT_RAW + else if (streq(format,"list")) + EX_FORMAT(ex) = FMT_LIST + else { + EX_FORMAT(ex) = FMT_BUILTIN + call exb_do_format (ex, format) + } +end + + +# EX_DO_HEADER - Process the header parameter. + +procedure ex_do_header (ex, header) + +pointer ex #i task struct pointer +char header[ARB] #i header parameter string + +bool streq() +int access() + +begin + if (DEBUG) { call eprintf("header='%s'\n") ; call pargstr (header) } + + if (streq(header,"no")) + EX_HEADER(ex) = HDR_NONE + else if (streq(header,"yes")) + EX_HEADER(ex) = HDR_SHORT + else if (streq(header,"long")) + EX_HEADER(ex) = HDR_LONG + else { + EX_HEADER(ex) = HDR_USER + if (access (header, 0, 0) == NO) + call error (2, "User-defined header file does not exist.") + else + call strcpy (header, HDRFILE(ex), SZ_FNAME) + } +end + + +# EX_DO_OUTTYPE - Process the output pixel type parameter. + +procedure ex_do_outtype (ex, outtype) + +pointer ex #i task struct pointer +char outtype[ARB] #i outtype parameter string + +int pixtype, nbytes + +int ex_ptype(), stridx() + +begin + if (DEBUG) { call eprintf("outtype='%s'\n");call pargstr (outtype) } + + if (outtype[1] == EOS) { + EX_OUTTYPE(ex) = EX_IMTYPE(ex) # use type of input image + return + } + + pixtype = stridx(outtype[1],"buirn") + if (pixtype == 0) + call error (2, "Invalid 'outtype' value specified\n") + + if (outtype[2] == EOS) { + if (outtype[1] == 'b') # set minimal sizes + nbytes = 1 + else if (outtype[1] == 'u') + nbytes = 2 + else + nbytes = 4 + } else + nbytes = outtype[2] - '1' + 1 + + # Set struct param. + EX_OUTTYPE(ex) = ex_ptype (pixtype, nbytes) + call sprintf (Memc[EX_OTPTR(ex)], SZ_FNAME, "%c%d") + call pargc (Memc[EX_OTPTR(ex)]) + call pargi (nbytes) +end + + +# EX_DO_BSWAP -- Read the byte-swap string an load the ip structure. + +procedure ex_do_bswap (ex, bswap) + +pointer ex #i task struct pointer +char bswap[ARB] #i byte swap string + +char ch, flag[SZ_FNAME] +int sp, i + +int strdic() + +begin + if (DEBUG) { call eprintf("swap='%s'\n");call pargstr (bswap) } + + sp = 1 + EX_BSWAP(ex) = NULL + while (bswap[sp] != EOS) { + i = 1 + for (ch=bswap[sp]; ch != EOS && ch != ','; ch=bswap[sp]) { + flag[i] = ch + i = i + 1 + sp = sp + 1 + } + flag[i] = EOS + + switch (strdic (flag, flag, SZ_FNAME, SWAP_STR)) { + case 1, 2: + EX_BSWAP(ex) = or (EX_BSWAP(ex), S_NONE) + case 3: + EX_BSWAP(ex) = or (EX_BSWAP(ex), S_ALL) + case 4: + EX_BSWAP(ex) = or (EX_BSWAP(ex), S_I2) + case 5: + EX_BSWAP(ex) = or (EX_BSWAP(ex), S_I4) + default: + break + } + } +end + + +# EX_DO_OUTBANDS - Parse the 'outbands' expressions. The operand tags are +# caught and space allocated. + +procedure ex_do_outbands (ex, outbands) + +pointer ex #i task struct pointer +char outbands[ARB] #i outbands expression string + +pointer sp, exp, expr +int fd, nchars, nexpr +int j, ip, plevel + +int open(), fstatl(), strlen() +char getc() + +errchk open + +begin + if (DEBUG) { call eprintf("outbands='%s'\n");call pargstr (outbands) } + + if (outbands[1] == EOS) { + EX_NIMAGES(ex) = EX_UNDEFINED # convert the whole image + EX_NEXPR(ex) = EX_UNDEFINED + return + } + + call smark (sp) + call salloc (exp, SZ_EXPSTR, TY_CHAR) + call aclrc (Memc[exp], SZ_EXPSTR) + + # If the outbands parameter is an @-file read in the expression from + # the file, otherwise just copy the param to the working buffer. + if (outbands[1] == '@') { + fd = open (outbands[2], READ_ONLY, TEXT_FILE) + nchars = fstatl (fd, F_FILESIZE) + 1 + call calloc (expr, max(SZ_EXPSTR,nchars), TY_CHAR) + ip = 0 + for (j=0; j 1) + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), PIXEL_STORAGE) + else if (EX_INTERLEAVE(ex) > 0 && EX_NEXPR(ex) > 1) + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), LINE_STORAGE) + else + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), BAND_STORAGE) + } + + call mfree (expr, TY_CHAR) + call sfree (sp) +end + + +# EX_PARSE_OPERANDS - Parse each expression string to break out the image +# operands. If the input image list is 2-D data we'll be generous and +# allow either 'b1' or 'i1', otherwise require the bands number. + +define SZ_TAG 7 + +procedure ex_parse_operands (ex) + +pointer ex #i task struct pointer + +pointer sp, expr +int i, ip, opnum +char ch, tag[SZ_TAG] + +int ctoi() + +begin + call smark (sp) + call salloc (expr, SZ_EXPSTR, TY_CHAR) + + EX_NIMOPS(ex) = 0 + EX_NIMAGES(ex) = 0 + do i = 1, EX_NEXPR(ex) { + call aclrc (Memc[expr], SZ_EXPSTR) + call strcpy (O_EXPR(ex,i), Memc[expr], SZ_EXPSTR) + + ip = 1 + while (Memc[expr+ip] != EOS) { + ch = Memc[expr+ip-1] + + # See if we have an operand descriptor. + if ((ch == 'b' || ch == 'i') && IS_DIGIT(Memc[expr+ip])) { + ip = ip + 1 + if (ctoi (Memc[expr], ip, opnum) == 0) + call error (4, "can't parse operand") + call sprintf (tag, SZ_TAG, "%c%d") + call pargc (ch) + call pargi (opnum) + + # Allocate the operand structure + if (IMOP(ex,opnum) == NULL) { + call ex_alloc_operand (IMOP(ex,opnum)) + call strcpy (tag, OP_TAG(IMOP(ex,opnum)), SZ_TAG) + EX_NIMOPS(ex) = EX_NIMOPS(ex) + 1 + } + + # For 2-D images allow either name interchangeably. Here + # we set the struct image band, we'll load the image de- + # scriptor later. + if (EX_IMDIM(ex) == 2) { + IO_BAND(IMOP(ex,opnum)) = 1 + EX_NIMAGES(ex) = EX_NIMOPS(ex) + } else if (EX_IMDIM(ex) == 3) { + if (ch == 'i') + call error (4, "Image operand illegal w/ 3-D lists") + IO_BAND(IMOP(ex,opnum)) = opnum + EX_NIMAGES(ex) = 1 + } + if (DEBUG) call zze_prop (IMOP(ex,opnum)) + } + ip = ip + 1 + } + } + + call sfree (sp) +end + + +# EX_PROCESS_IMAGE - Process the image pixels. + +procedure ex_process_image (ex) + +pointer ex #i task struct pointer + +int flags + +begin + flags = EX_OUTFLAGS(ex) + + # Create the (if any) requested colormap first. + if (bitset (flags, OF_MKCMAP)) + call ex_mkcmap (ex) + + # Process the images. + if (EX_FORMAT(ex) == FMT_BUILTIN) { + # Write the builtin format. + call exb_process_image (ex) + + } else { + if (bitset (flags, OF_BAND) || bitset (flags, BAND_STORAGE)) + call ex_no_interleave (ex) + else if (bitset (flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call ex_ln_interleave (ex) + else if (bitset (flags, PIXEL_STORAGE)) + call ex_px_interleave (ex) + else + call error (0, "Unknown processing param.") + } + + #if (EX_VERBOSE(ex) == YES) { + call eprintf (" Status: Done. \n") + call flush (STDERR) + #} +end + + +# EX_PRINFO - Print verbose information about the conversion. + +procedure ex_prinfo (ex, np) + +pointer ex #i task struct pointer +pointer np[ARB] #i ptr to image names + +pointer im +int i, j, flags + +begin + # Print information about the input images. + call eprintf (" Input images:\n") + do i = 1, EX_NIMAGES(ex) { + im = IO_IMPTR(IMOP(ex,i)) + call eprintf ("\t%s: %s %40t") + call pargstr (OP_TAG(IMOP(ex,i))) + call pargstr (Memc[np[i]]) + do j = 1, IM_NDIM(im) { + call eprintf ("%d ") + call pargi (IM_LEN(im,j)) + if (j < IM_NDIM(im)) + call eprintf ("x ") + } + call eprintf (" `%s'\n") + call pargstr (IM_TITLE(im)) + } + + # Print information about the output file. + flags = EX_OUTFLAGS(ex) + call eprintf (" Output file:\n") + call eprintf ("\tName: %30t%s\n") + call pargstr (BFNAME(ex)) + call eprintf ("\tFormat: %30t%s\n") + switch (EX_FORMAT(ex)) { + case FMT_RAW: call pargstr ("Raw") + case FMT_LIST: call pargstr ("List") + case FMT_BUILTIN: + call exb_pname (ex) + } + + if (EX_FORMAT(ex) == FMT_RAW) { + call eprintf ("\tHeader: %30t%s%s\n") + switch(EX_HEADER(ex)) { + case HDR_NONE: call pargstr ("None") ; call pargstr ("") + case HDR_SHORT: call pargstr ("Short") ; call pargstr ("") + case HDR_LONG: call pargstr ("Long") ; call pargstr ("") + case HDR_USER: call pargstr ("User: ") + call pargstr (HDRFILE(ex)) + } + } + + call eprintf ("\tByte Order: %30t%s\n") + if (EX_FORMAT(ex) == FMT_BUILTIN) + call exb_pendian (ex) + else if (EX_BSWAP(ex) == 0 && (BYTE_SWAP2==NO || BYTE_SWAP4==NO)) + call pargstr ("Most Significant Byte First") + else + call pargstr ("Least Significant Byte First") + + call eprintf ("\tResolution: %30t%d x %d\n") + call pargi (EX_OCOLS(ex)) + call pargi (EX_OROWS(ex)) + + call eprintf ("\tPixel Storage: %30t%s\n") + if (EX_FORMAT(ex) == FMT_BUILTIN) + call exb_pstorage (ex) + else if (bitset(flags, OF_BAND) || bitset(flags,BAND_STORAGE)) + call pargstr ("Band Interleaved") + else if (bitset(flags, OF_LINE) || bitset(flags,LINE_STORAGE)) + call pargstr ("Line Interleaved") + else if (bitset(flags,PIXEL_STORAGE)) + call pargstr ("Pixel Interleaved") + else + call pargstr ("Unknown") + + if (bitset(flags, OF_CMAP) || bitset(flags, OF_MKCMAP)) + call eprintf ("\tType: %30t8-bit Color Indexed\n") + else { + if (bitset(flags, OF_BAND) && EX_NEXPR(ex) > 1) + call eprintf ("\tType: %30tGrayscale\n") + else + call eprintf ("\tType: %30tRGB\n") + } + + if (bitset(flags, OF_CMAP) || bitset(flags, OF_MKCMAP)) { + call eprintf ("\tColor Table: %30t%d entries\n") + call pargi (EX_NCOLORS(ex)) + } else + call eprintf ("\tColor Table: %30tnone\n") + + if (DEBUG && EX_NEXPR(ex) != 0) { + call eprintf ("\tEvaluated Expressions:\n") + do i = 1, EX_NEXPR(ex) { + call eprintf ("\t %d) %s\n") + call pargi (i) + call pargstr (O_EXPR(ex,i)) + } + } +end + + +# EX_PTYPE -- For a given outtype parameter return the corresponding IRAF +# data type. + +define NTYPES 6 +define NBITPIX 4 + +int procedure ex_ptype (type, nbytes) + +int type #i pixel type +int nbytes #i number of bytes + +int i, pt, pb, ptype +int tindex[NTYPES], bindex[NBITPIX], ttbl[NTYPES*NBITPIX] + +data tindex /PT_BYTE, PT_UINT, PT_INT, PT_IEEE, PT_NATIVE, PT_SKIP/ +data bindex /1, 2, 4, 8/ + +data (ttbl(i), i= 1, 4) /TY_UBYTE, TY_USHORT, TY_INT, 0/ # B +data (ttbl(i), i= 5, 8) /TY_UBYTE, TY_USHORT, 0, 0/ # U +data (ttbl(i), i= 9,12) /TY_UBYTE, TY_SHORT, TY_INT, 0/ # I +data (ttbl(i), i=13,16) / 0, 0, TY_REAL, TY_DOUBLE/ # R +data (ttbl(i), i=17,20) / 0, 0, TY_REAL, TY_DOUBLE/ # N +data (ttbl(i), i=21,24) /TY_UBYTE, TY_USHORT, TY_REAL, TY_DOUBLE/ # X + +begin + if (type == 0 || nbytes == 0) # uninitialized values + return (0) + + pt = NTYPES + do i = 1, NTYPES { + if (tindex[i] == type) + pt = i + } + pb = NBITPIX + do i = 1, NBITPIX { + if (bindex[i] == nbytes) + pb = i + } + + ptype = ttbl[(pt-1)*NBITPIX+pb] + + if (DEBUG) { call eprintf("pt=%d pb=%d -> ptype=%d\n") + call pargi (pt) ; call pargi (pb) ; call pargi (ptype) } + + if (ptype == 0) + call error (0, "Invalid outtype specified.") + else + return (ptype) +end + + +# EX_MKFNAME - Create an output filename based on the requested format. + +procedure ex_mkfname (ex, fname) + +pointer ex #i task struct pointer +char fname[ARB] # generate the output filename + +pointer sp, suffix, test +int fnextn() +bool streq() +pointer exb_fmt_ext() + +begin + call smark (sp) + call salloc (test, SZ_FNAME, TY_CHAR) + + if (EX_FORMAT(ex) == FMT_BUILTIN) + suffix = exb_fmt_ext (ex) + else if (EX_FORMAT(ex) == FMT_RAW || EX_FORMAT(ex) == FMT_LIST) { + call strcpy (fname, BFNAME(ex), SZ_FNAME) + call sfree (sp) + return + } + + # If the current extension is not the same as the format extn add it. + if (fnextn (fname, Memc[test], SZ_FNAME) > 0) { + if (streq(Memc[test], Memc[suffix+1])) { + call strcpy (fname, BFNAME(ex), SZ_FNAME) + call sfree (sp) + return + } + } + + call sprintf (BFNAME(ex), SZ_FNAME, "%s%s") + call pargstr (fname) + call pargstr (Memc[suffix]) + + call mfree (suffix, TY_CHAR) + call sfree (sp) +end + + +# EX_ALLOC_OUTBANDS -- Allocate an outbands structure. + +procedure ex_alloc_outbands (op) + +pointer op #i outbands struct pointer + +begin + call calloc (op, LEN_OUTBANDS, TY_STRUCT) + call calloc (OB_EXPSTR(op), SZ_EXPSTR, TY_CHAR) +end + + +# EX_FREE_OUTBANDS -- Free an outbands structure. + +procedure ex_free_outbands (op) + +pointer op #i outbands struct pointer + +begin + call mfree (OB_EXPSTR(op), TY_CHAR) + call mfree (op, TY_STRUCT) +end + + +# EX_ALLOC_OPERAND -- Allocate an operand structure. + +procedure ex_alloc_operand (op) + +pointer op #i operand struct pointer + +begin + call calloc (op, LEN_OPERAND, TY_STRUCT) + call calloc (IO_TAG(op), SZ_FNAME, TY_CHAR) +end + + +# EX_FREE_OPERAND -- Free an operand structure. + +procedure ex_free_operand (op) + +pointer op #i operand struct pointer + +begin + call mfree (IO_TAG(op), TY_CHAR) + call mfree (op, TY_STRUCT) +end diff --git a/pkg/dataio/export/zzedbg.x b/pkg/dataio/export/zzedbg.x new file mode 100644 index 00000000..d1eba755 --- /dev/null +++ b/pkg/dataio/export/zzedbg.x @@ -0,0 +1,157 @@ +include +include "exbltins.h" +include "export.h" + +procedure zze_prstruct (whence, ex) + +char whence[SZ_FNAME] +pointer ex +int i + +begin + call eprintf ("%s:\n") ; call pargstr (whence) + call eprintf ("\tformat=%s %s outflags=%d interleave=%d bswap=%s\n") + switch (EX_FORMAT(ex)) { + case FMT_RAW: call pargstr ("FMT_RAW") + case FMT_LIST: call pargstr ("FMT_LIST") + case FMT_BUILTIN: call pargstr ("FMT_BUILTIN") + default: call pargstr ("ERR") + } + switch (EX_BLTIN(ex)) { + case EPS: call pargstr ("(eps)") + case GIF: call pargstr ("(gif)") + case PGM: call pargstr ("(pgm)") + case PPM: call pargstr ("(ppm)") + case RAS: call pargstr ("(ras)") + case RGB: call pargstr ("(rgb)") + case XWD: call pargstr ("(xwd)") + default: call pargstr ("") + } + call pargi (EX_OUTFLAGS(ex)) + call pargi (EX_INTERLEAVE(ex)) + switch(EX_BSWAP(ex)) { + case S_NONE: call pargstr ("S_NONE") + case S_ALL: call pargstr ("S_ALL") + case S_I2: call pargstr ("S_I2") + case S_I4: call pargstr ("S_I4") + default: call pargstr ("ERR") + } + call eprintf ("\touttype=%s header='%s' verbose=%d\n") + switch(EX_OUTTYPE(ex)) { + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + default: call pargstr ("ERR") + } + switch(EX_HEADER(ex)) { + case HDR_NONE: call pargstr ("HDR_NONE") + case HDR_SHORT: call pargstr ("HDR_SHORT") + case HDR_LONG: call pargstr ("HDR_LONG") + case HDR_USER: call pargstr ("HDR_USER") + default: call pargstr ("ERR") + } + call pargi (EX_VERBOSE(ex)) + call eprintf ("\toutbands (%d):\n") ; call pargi (EX_NEXPR(ex)) + do i = 1, EX_NEXPR(ex) + call zze_proband (ex, i) + call eprintf ("\tocols=%d orows=%d:\n") + call pargi (EX_OCOLS(ex)) ; call pargi (EX_OROWS(ex)) + call eprintf ("\tnimages=%d nimops=%d ncols=%d nlines=%d:\n") + call pargi (EX_NIMAGES(ex)) + call pargi (EX_NIMOPS(ex)) + call pargi (EX_NCOLS(ex)) + call pargi (EX_NLINES(ex)) + do i = 1, MAX_OPERANDS { + if (IMOP(ex,i) != NULL) { + call eprintf ("\t ") ; call zze_prop (IMOP(ex,i)) + } + } + + call eprintf ("\tuser header = '%s' LUT file = '%s'\n") + call pargstr (HDRFILE(ex)) + call pargstr (LUTFILE(ex)) + call eprintf ("\tEPS dpi = %g scale = %g ncolors = %d\n") + call pargr (EX_PSDPI(ex)) + call pargr (EX_PSSCALE(ex)) + call pargi (EX_NCOLORS(ex)) + call eprintf ("\tbrightness = %g contrast = %g\n") + call pargr (EX_BRIGHTNESS(ex)) + call pargr (EX_CONTRAST(ex)) + call flush (STDERR) +end + + +procedure zze_proband (ex, band) + +pointer ex +int band + +begin + call eprintf ("\t ob=%d w=%d h=%d expr='%s'\n") + call pargi (OBANDS(ex,band)) + call pargi (OB_WIDTH(OBANDS(ex,band))) + call pargi (OB_HEIGHT(OBANDS(ex,band))) + call pargstr (O_EXPR(ex,band)) +end + + +procedure zze_prop (o) + +pointer o +char buf[8] +int type, ex_ptype() + +begin + if (o == NULL) + return + + call sprintf (buf, 8, " buirnx") + type = ex_ptype(IO_TYPE(o), IO_NBYTES(o)) + call eprintf("(o=%d im=%d band=%d tag=%s (t='%c' N=%d=>%s) Np=%d %d)\n") + call pargi (o) + call pargi (IO_IMPTR(o)) + call pargi (IO_BAND(o)) + if (IO_TAG(o) == NULL) call pargstr ("") + else call pargstr (OP_TAG(o)) + #call pargc (buf[IO_TYPE(o)+1]) + call pargc (IO_TYPE(o)) + call pargi (IO_NBYTES(o)) + switch (type) { + case TY_UBYTE: call pargstr ("TY_UBYTE") + case TY_USHORT: call pargstr ("TY_USHORT") + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + default: call pargstr ("ERR") + } + call pargi (IO_NPIX(o)) + call pargi (IO_DATA(o)) + call flush (STDERR) +end + + +procedure zze_pevop (o) + +pointer o + +begin + call eprintf ("o=%d type=%d len=%d flags=%d ") + call pargi (o) + call pargi (O_TYPE(o)) + call pargi (O_LEN(o)) + call pargi (O_FLAGS(o)) + switch (O_TYPE(o)) { + case TY_CHAR: call eprintf ("val='%s'\n") ; call pargstr (O_VALC(o)) + case TY_SHORT: call eprintf ("val=%d\n") ; call pargs (O_VALS(o)) + case TY_INT: call eprintf ("val=%d\n") ; call pargi (O_VALI(o)) + case TY_LONG: call eprintf ("val=%d\n") ; call pargl (O_VALL(o)) + case TY_REAL: call eprintf ("val=%g\n") ; call pargr (O_VALR(o)) + case TY_DOUBLE: call eprintf ("val=%g\n") ; call pargd (O_VALD(o)) + default: call eprintf ("ptr=%d\n") ; call pargi (O_VALP(o)) + } + call flush (STDERR) +end diff --git a/pkg/dataio/fits/fits_cards.x b/pkg/dataio/fits/fits_cards.x new file mode 100644 index 00000000..0ddfa230 --- /dev/null +++ b/pkg/dataio/fits/fits_cards.x @@ -0,0 +1,292 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "wfits.h" + +# WFT_STANDARD_CARD -- Procedure for fetching the minimum header +# parameters required by fits. The end card is encoded separately. + +int procedure wft_standard_card (cardno, im, fits, axisno, card) + +int cardno # number of FITS standard card +pointer im # pointer to the IRAF image +pointer fits # pointer to the FITS structure +int axisno # axis number +char card[ARB] # FITS card image + +char keyword[LEN_KEYWORD] +int len_object +int strlen() +errchk wft_encodeb, wft_encodei, wft_encodel, wft_encode_axis + +begin + # Get mandatory keywords. + switch (cardno) { + case FIRST_CARD: + if (XTENSION(fits) == EXT_PRIMARY) { + call wft_encodeb ("SIMPLE", YES, card, "FITS STANDARD") + } else { + len_object = max (min (LEN_OBJECT, strlen ("IMAGE")), + LEN_STRING) + call wft_encodec ("XTENSION", "IMAGE", len_object, card, + "IMAGE EXTENSION") + } + case SECOND_CARD: + call wft_encodei ("BITPIX", FITS_BITPIX(fits), card, + "FITS BITS/PIXEL") + case THIRD_CARD: + call wft_encodei ("NAXIS", NAXIS(im), card, "NUMBER OF AXES") + default: + call wft_encode_axis ("NAXIS", keyword, axisno) + call wft_encodel (keyword, NAXISN(im, axisno), card, "") + axisno = axisno + 1 + } + + return (YES) +end + + +# WFT_OPTION_CARD -- Procedure for fetching optional FITS header parameters. +# At present these are bscale, bzero, bunit, blank, object, origin, date, +# irafmax, irafmin, iraf type and iraf bits per pixel. Blank is only encoded +# if there are a nonzero number of blanks in the IRAF image. Bunit and object +# are only encoded if the appropriate IRAF strings are defined. Bzero, bscale, +# irafmax, irafmin, iraf type and iraf bits per pixel are only encoded if +# there is a pixel file. + +int procedure wft_option_card (im, fits, optiono, card) + +pointer im # pointer to the IRAF image +pointer fits # pointer to FITS structure +int optiono # number of the option card +char card[ARB] # FITS card image + +char datestr[LEN_DATE] +int len_object, stat +int strlen() +errchk wft_encoded, wft_encodec, wft_encode_blank, wft_encoder, wft_encodei +errchk wft_encode_date +include "wfits.com" + +begin + stat = YES + + # get optional keywords + switch (optiono) { + case KEY_EXTEND: + if (XTENSION(fits) == EXT_IMAGE || wextensions == NO) + stat = NO + else + call wft_encodeb ("EXTEND", YES, card, + "STANDARD EXTENSIONS MAY BE PRESENT") + case KEY_PCOUNT: + if (XTENSION(fits) == EXT_PRIMARY) + stat = NO + else + call wft_encodei ("PCOUNT", 0, card, "NO RANDOM PARAMETERS") + case KEY_GCOUNT: + if (XTENSION(fits) == EXT_PRIMARY) + stat = NO + else + call wft_encodei ("GCOUNT", 1, card, "ONLY ONE GROUP") + case KEY_BSCALE: + if ((NAXIS(im) <= 0) || (FITS_BITPIX(fits) < 0)) + stat = NO + else { + call wft_encoded ("BSCALE", BSCALE(fits), card, + "REAL = TAPE*BSCALE + BZERO", NDEC_DOUBLE) + } + case KEY_BZERO: + if ((NAXIS(im) <= 0) || (FITS_BITPIX(fits) < 0)) + stat = NO + else + call wft_encoded ("BZERO", BZERO(fits), card, "", NDEC_DOUBLE) + case KEY_BUNIT: + stat = NO + case KEY_BLANK: + stat = NO + #if (NBPIX(im) == 0) + #stat = NO + #else + #call wft_encode_blank ("BLANK", BLANK_STRING(fits), card, + #"TAPE VALUE OF BLANK PIXEL") + case KEY_OBJECT: + if (OBJECT(im) == EOS) + stat = NO + else { + len_object = max (min (LEN_OBJECT, strlen (OBJECT(im))), + LEN_STRING) + call wft_encodec ("OBJECT", OBJECT(im), len_object, card, "") + } + case KEY_ORIGIN: + call wft_encodec ("ORIGIN", "KPNO-IRAF", LEN_ORIGIN, card, "") + case KEY_DATE: + call wft_encode_date (datestr, LEN_DATE) + len_object = max (min (LEN_OBJECT, strlen (datestr)), LEN_STRING) + call wft_encodec ("DATE", datestr, len_object, card, "") + case KEY_IRAFNAME: + len_object = max (min (LEN_OBJECT, strlen (IRAFNAME(fits))), + LEN_STRING) + call wft_encodec ("IRAFNAME", IRAFNAME(fits), len_object, card, + "NAME OF IRAF IMAGE FILE") + case KEY_IRAFMAX: + if (NAXIS(im) <= 0) + stat = NO + else + call wft_encoder ("IRAF-MAX", IRAFMAX(fits), card, "DATA MAX", + NDEC_REAL) + case KEY_IRAFMIN: + if (NAXIS(im) <= 0) + stat = NO + else + call wft_encoder ("IRAF-MIN", IRAFMIN(fits), card, "DATA MIN", + NDEC_REAL) + case KEY_IRAFBP: + if (NAXIS(im) <= 0) + stat = NO + else + call wft_encodei ("IRAF-BPX", DATA_BITPIX(fits), card, + "DATA BITS/PIXEL") + case KEY_IRAFTYPE: + if (NAXIS(im) <= 0) + stat = NO + else + call wft_encodec ("IRAFTYPE", TYPE_STRING(fits), LEN_STRING, + card, "PIXEL TYPE") + default: + stat = NO + } + + optiono = optiono + 1 + + return (stat) +end + + +# WFT_HISTORY_CARD -- Procedure to fetch a single history line, trim newlines +# and pad with blanks to size LEN_CARD in order to create a FITS HISTORY card. + +int procedure wft_history_card (im, hp, card) + +pointer im # pointer to the IRAF image +int hp # pointer to first character to extract from string +char card[ARB] # FITS card image + +char cval +char chfetch() + +begin + if (chfetch (HISTORY(im), hp, cval) == EOS) + return (NO) + else { + hp = hp - 1 + call strcpy ("HISTORY ", card, LEN_KEYWORD) + call wft_fits_card (HISTORY(im), hp, card, COL_VALUE - 2, LEN_CARD, + '\n') + return (YES) + } +end + + +# WFT_UNKNOWN_CARD -- Procedure to fetch a single unknown +# "line", trim newlines and pad blanks to size LEN_CARD in order to +# create an unknown keyword card. At present user area information is +# assumed to be in the form of FITS card images, less then or equal to +# 80 characters and delimited by a newline. + +int procedure wft_unknown_card (im, up, card) + +pointer im # pointer to the IRAF image +int up # pointer to next character in the unknown string +char card[ARB] # FITS card image + +char cval +int stat, axis, index +char chfetch() +int strmatch(), ctoi() + +begin + if (chfetch (UNKNOWN(im), up, cval) == EOS) + return (NO) + else { + up = up - 1 + stat = NO + while (stat == NO) { + call wft_fits_card (UNKNOWN(im), up, card, 1, LEN_CARD, '\n') + if (card[1] == EOS) + break + if (strmatch (card, "^GROUPS ") != 0) { + stat = NO + } else if (strmatch (card, "^SIMPLE ") != 0) { + stat = NO + } else if (strmatch (card, "^BITPIX ") != 0) { + stat = NO + } else if (strmatch (card, "^NAXIS ") != 0) { + stat = NO + } else if (strmatch (card, "^NAXIS") != 0) { + index = LEN_NAXIS_KYWRD + 1 + if (ctoi (card, index, axis) > 0) + stat = NO + else + stat = YES + } else if (strmatch (card, "^GCOUNT ") != 0) { + stat = NO + } else if (strmatch (card, "^PCOUNT ") != 0) { + stat = NO + } else if (strmatch (card, "^PSIZE ") != 0) { + stat = NO + } else if (strmatch (card, "^BSCALE ") != 0) { + stat = NO + } else if (strmatch (card, "^BZERO ") != 0) { + stat = NO + } else if (strmatch (card, "^BLANK ") != 0) { + stat = NO + } else if (strmatch (card, "^IRAF-MAX") != 0) { + stat = NO + } else if (strmatch (card, "^IRAF-MIN") != 0) { + stat = NO + } else if (strmatch (card, "^IRAFTYPE") != 0) { + stat = NO + } else if (strmatch (card, "^IRAF-B/P") != 0) { + stat = NO + } else if (strmatch (card, "^IRAF-BPX") != 0) { + stat = NO + } else if (strmatch (card, "^FILENAME") != 0) { + stat = NO + } else if (strmatch (card, "^IRAFNAME") != 0) { + stat = NO + } else if (strmatch (card, "^EXTEND ") != 0) { + stat = NO + } else if (strmatch (card, "^EXTNAME ") != 0) { + stat = NO + } else if (strmatch (card, "^EXTVER ") != 0) { + stat = NO + } else if (strmatch (card, "^INHERIT ") != 0) { + stat = NO + } else if (strmatch (card, "^IRAF-TLM") != 0) { + stat = NO + } else if (strmatch (card, "^OBJECT ") != 0) { + stat = NO + } else if (strmatch (card, "^END ") != 0) { + stat = NO + } else + stat = YES + } + + return (stat) + } +end + + +# WFT_LAST_CARD -- Procedure to encode the FITS end card. + +int procedure wft_last_card (card) + +char card[ARB] # FITS card image + +begin + call sprintf (card, LEN_CARD, "%-8.8s %70w") + call pargstr ("END") + + return (YES) +end diff --git a/pkg/dataio/fits/fits_files.x b/pkg/dataio/fits/fits_files.x new file mode 100644 index 00000000..ce2c553c --- /dev/null +++ b/pkg/dataio/fits/fits_files.x @@ -0,0 +1,374 @@ +include +include + +define DEF_MAXNCOLS 1000 +define DEF_MAXNLINES 4096 +define MAX_NRANGES 100 + + +# RFT_FLIST -- Decode a list of files and associated extensions into a pixel +# list. + +pointer procedure rft_flist (file_list, first_file, last_file, nfiles) + +char file_list[ARB] # the input file list string +int first_file # the first file in the list +int last_file # the last file in the list +int nfiles # the number of files in the list + +int i, j, maxncols, maxnlines, nrfiles, rp, rbegin, rend, rstep +int last_ext, ebegin, eend, estep, ep, nefiles +pointer sp, extensions, str, axes, pl + +bool pl_linenotempty() +int rft_gfranges() +pointer pl_create() + +begin + # Allocate some working space. + call smark (sp) + call salloc (extensions, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (axes, 2, TY_INT) + + # Initialize the file list. + pl = NULL + maxncols = DEF_MAXNCOLS + maxnlines = DEF_MAXNLINES + + repeat { + + # Initialize the file counter parameters. + first_file = INDEFI + last_file = INDEFI + nfiles = 0 + rp = 1 + + # Open the file list. + Memi[axes] = maxncols + Memi[axes+1] = maxnlines + pl = pl_create (2, Memi[axes], 1) + + # Decode the file list. + nrfiles = rft_gfranges (file_list, rp, YES, maxnlines, rbegin, + rend, rstep, NO, Memc[extensions]) + while (nrfiles > 0) { + + # Check the file number limits and terminate the loop if + # the current list size is exceeded. + if (IS_INDEFI(first_file)) + first_file = rbegin + else + first_file = min (rbegin, first_file) + if (IS_INDEFI(last_file)) + last_file = rend + else + last_file = max (last_file, rend) + if (last_file > maxnlines) + break + + # Initialize the extensions list decoding. + ep = 1 + last_ext = INDEFI + + # Decode the associated extensions files. If the extensions + # list is empty + nefiles = rft_gfranges (Memc[extensions], ep, YES, maxncols, + ebegin, eend, estep, YES, Memc[str]) + while (nefiles > 0) { + + # Check the extensions number limits and quit if they + # are exceeded. + if (IS_INDEFI(last_ext)) + last_ext = eend + else + last_ext = max (last_ext, eend) + if (last_ext > maxncols) + break + + # Set the appropriate elements in the list. + if (rstep == 1) { + if (estep == 1) + call pl_box (pl, ebegin, rbegin, eend, + rend, PIX_SET + PIX_VALUE(1)) + else { + do i = ebegin, eend, estep + call pl_box (pl, i, rbegin, i, rend, + PIX_SET + PIX_VALUE(1)) + } + } else { + do i = rbegin, rend, rstep { + do j = ebegin, eend, estep + call pl_point (pl, j, i, PIX_SET + + PIX_VALUE(1)) + } + } + + nefiles = rft_gfranges (Memc[extensions], ep, NO, maxncols, + ebegin, eend, estep, YES, Memc[str]) + } + + # Break if an extensions list decode error occurs. + if (nefiles == 0) + break + + nrfiles = rft_gfranges (file_list, rp, NO, maxnlines, rbegin, + rend, rstep, NO, Memc[extensions]) + } + + # Break if a file or extensions list decode error ocurred. + if (nrfiles == 0 || nefiles == 0) + break + + # If the file or extensions list is larger than the current maximum + # then free the list increase the default space and repeat the + # procedure. + + if (!IS_INDEFI(last_file)) { + if (last_file > maxnlines) { + if (pl != NULL) + call pl_close (pl) + pl = NULL + maxnlines = maxnlines + DEF_MAXNLINES + } else { + do i = first_file, last_file { + Memi[axes] = 1 + Memi[axes+1] = i + if (pl_linenotempty (pl, Memi[axes])) + nfiles = nfiles + 1 + } + } + } + + if (!IS_INDEFI(last_ext)) { + if (last_ext > maxncols) { + if (pl != NULL) + call pl_close (pl) + pl = NULL + maxncols = maxncols + DEF_MAXNCOLS + } + } + + } until (pl != NULL) + + # Free space. + call sfree (sp) + + # If the file list is empty or a decode error occurred return + # a NULL list, otherwise return the pointer to the list. + + if (nfiles <= 0 || nrfiles == 0 || nefiles == 0) { + nfiles = 0 + first_file = INDEFI + last_file = INDEFI + call pl_close (pl) + return (NULL) + } else + return (pl) +end + + +# RFT_GFRANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Each range may have an +# associated extensions lists delimited by square brackets. Return as output +# each range in sequence. Range limits must be positive nonnegative integers. +# EOF is returned if the end of the file_list is reached. 0 is returned if a +# conversion error takes place. Otherwise the number of elements in the +# range is returned. + +int procedure rft_gfranges (range_string, ip, firstr, rmax, rbegin, rend, + rstep, zeroindex, extensions) + +char range_string[ARB] # range string to be decoded +int ip # the range string pointer +int firstr # first range to be returned +int rmax # the maximum file number +int rbegin # the begining of the range +int rend # the end of the range +int rstep # the range step size +int zeroindex # allow zero indexing ? +char extensions[ARB] # the output extensions string + +int ep, itemp +int ctoi() + +begin + # Initialize. + if (zeroindex == YES) { + rbegin = 0 + rend = rmax - 1 + } else { + rbegin = 1 + rend = rmax + } + rstep = 1 + extensions[1] = EOS + + # Return default range if the range string is NULL. + if (range_string[ip] == EOS) { + rbegin = 1 + rend = rmax + if (firstr == YES) + return (rend) + else + return (EOF) + } + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '-', 'x', *, or EOS. + if (range_string[ip] == EOS) { # end of list + rbegin = 1 + rend = rmax + if (firstr == YES) + return (rend) + else + return (EOF) + } else if (range_string[ip] == '*') { + ; + } else if (range_string[ip] == '-') { + ; + } else if (range_string[ip] == 'x') { + ; + } else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, rbegin) == 0) + return (0) + else if (zeroindex == NO) { + if (rbegin <= 0) + return (0) + } else { + if (rbegin < 0) + return (0) + } + } else + return (0) + + # Extract extensions file list. + if (range_string[ip] == '[') { + ip = ip + 1 + ep = 1 + while (range_string[ip] != EOS) { + if (range_string[ip] == ']') { + ip = ip + 1 + break + } + extensions[ep] = range_string[ip] + ip = ip + 1 + ep = ep + 1 + } + extensions[ep] = EOS + if (range_string[ip-1] != ']') + return (0) + } + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', 'x', or '*' otherwise last = first. + if (range_string[ip] == '*') + ; + else if (range_string[ip] == 'x') + ; + else if (range_string[ip] == '-') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, rend) == 0) + return (0) + else if (zeroindex == NO) { + if (rend <= 0) + return (0) + } else { + if (rend < 0) + return (0) + } + } else if (range_string[ip] == 'x') + ; + else + return (0) + } else + rend = rbegin + + # Skip extensions files for now. + if (range_string[ip] == '[') { + ip = ip + 1 + ep = 1 + while (range_string[ip] != EOS) { + if (range_string[ip] == ']') { + ip = ip + 1 + break + } + extensions[ep] = range_string[ip] + ip = ip + 1 + ep = ep + 1 + } + extensions[ep] = EOS + if (range_string[ip-1] != ']') + return (0) + } + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == '*') + ip = ip + 1 + else if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, rstep) == 0) + ; + else if (rstep <= 0) + return (0) + } else if (range_string[ip] == '-') + ; + else + return (0) + } + + # Skip extensions files for now. + if (range_string[ip] == '[') { + ip = ip + 1 + ep = 1 + while (range_string[ip] != EOS) { + if (range_string[ip] == ']') { + ip = ip + 1 + break + } + extensions[ep] = range_string[ip] + ip = ip + 1 + ep = ep + 1 + } + extensions[ep] = EOS + if (range_string[ip-1] != ']') + return (0) + } + + # Output the range triple. + if (rend < rbegin) { + itemp = rbegin + rbegin = rend + rend = itemp + } + if (zeroindex == YES) { + rbegin = rbegin + 1 + rend = rend + 1 + } + return (abs (rend - rbegin) / rstep + 1 ) +end + + diff --git a/pkg/dataio/fits/fits_params.x b/pkg/dataio/fits/fits_params.x new file mode 100644 index 00000000..6911a925 --- /dev/null +++ b/pkg/dataio/fits/fits_params.x @@ -0,0 +1,248 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "wfits.h" + +# WFT_ENCODEB -- Procedure to encode a boolean parameter into a FITS card. + +procedure wft_encodeb (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +int param # integer parameter equal to YES/NO +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +char truth + +begin + if (param == YES) + truth = 'T' + else + truth = 'F' + + call sprintf (card, LEN_CARD, "%-8.8s= %20c / %-45.45s") + call pargstr (keyword) + call pargc (truth) + call pargstr (comment) +end + + +# WFT_ENCODEI -- Procedure to encode an integer parameter into a FITS card. + +procedure wft_encodei (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +int param # integer parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-45.45s") + call pargstr (keyword) + call pargi (param) + call pargstr (comment) +end + + +# WFT_ENCODEL -- Procedure to encode a long parameter into a FITS card. + +procedure wft_encodel (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +long param # long integer parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-45.45s") + call pargstr (keyword) + call pargl (param) + call pargstr (comment) +end + + +# WFT_ENCODER -- Procedure to encode a real parameter into a FITS card. + +procedure wft_encoder (keyword, param, card, comment, precision) + +char keyword[ARB] # FITS keyword +real param # real parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment card +int precision # precision of real + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-45.45s") + call pargstr (keyword) + call pargi (precision) + call pargr (param) + call pargstr (comment) +end + + +# WFT_ENCODED -- Procedure to encode a double parameter into a FITS card. + +procedure wft_encoded (keyword, param, card, comment, precision) + +char keyword[ARB] # FITS keyword +double param # double parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string +int precision # FITS precision + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-45.45s") + call pargstr (keyword) + call pargi (precision) + call pargd (param) + call pargstr (comment) +end + + +# WFT_ENCODE_AXIS -- Procedure to add the axis number to axis dependent +# keywords. + +procedure wft_encode_axis (root, keyword, axisno) + +char root[ARB] # FITS root keyword +char keyword[ARB] # FITS keyword +int axisno # FITS axis number + +begin + call strcpy (root, keyword, LEN_KEYWORD) + call sprintf (keyword, LEN_KEYWORD, "%-5.5s%-3.3s") + call pargstr (root) + call pargi (axisno) +end + + +# WFT_ENCODEC -- Procedure to encode an IRAF string parameter into a FITS card. + +procedure wft_encodec (keyword, param, maxch, card, comment) + +char keyword[ARB] # FITS keyword +char param[ARB] # FITS string parameter +int maxch # maximum number of characters in string parameter +char card[ARB] # FITS card image +char comment[ARB] # comment string + +char strparam[LEN_ALIGN+2] +int maxchar, nblanks + +begin + maxchar = min (maxch, LEN_OBJECT) + if (maxchar <= LEN_ALIGN - 1) { + strparam[1] = '\'' + call sprintf (strparam[2], maxchar, "%*.*s") + call pargi (-maxchar) + call pargi (maxchar) + call pargstr (param) + strparam[maxchar+2] = '\'' + strparam[maxchar+3] = EOS + call sprintf (card, LEN_CARD, "%-8.8s= %-20.20s / %-45.45s") + call pargstr (keyword) + call pargstr (strparam) + call pargstr (comment) + } else { + nblanks = LEN_OBJECT - maxchar + if (comment[1] == EOS) + call sprintf (card, LEN_CARD, "%-8.8s= '%*.*s' %*.*s") + else + call sprintf (card, LEN_CARD, "%-8.8s= '%*.*s' / %*.*s") + call pargstr (keyword) + call pargi (-maxchar) + call pargi (maxchar) + call pargstr (param) + call pargi (-nblanks) + call pargi (nblanks) + call pargstr (comment) + } +end + + +# WFT_ENCODE_BLANK -- Procedure to encode the FITS blank parameter. Necessary +# because the 32 bit blank value equals INDEFL. + +procedure wft_encode_blank (keyword, blank_str, card, comment) + +char keyword[ARB] # FITS keyword +char blank_str[ARB] # string containing values of FITS blank integer +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.20s / %-45.45s") + call pargstr (keyword) + call pargstr (blank_str) + call pargstr (comment) +end + + +# WFT_ENCODE_DATE -- Procedure to encode the date in the form dd-mm-yy. + +procedure wft_encode_date (datestr, szdate) + +char datestr[ARB] # string containing the date +int szdate # number of chars in the date string + +long ctime +int time[LEN_TMSTRUCT] +long clktime(), lsttogmt() + +begin + ctime = clktime (long (0)) + ctime = lsttogmt (ctime) + call brktime (ctime, time) + + if (TM_YEAR(time) >= NEW_CENTURY) { + call sprintf (datestr, szdate, "%04d-%02d-%02dT%02d:%02d:%02d") + call pargi (TM_YEAR(time)) + call pargi (TM_MONTH(time)) + call pargi (TM_MDAY(time)) + call pargi (TM_HOUR(time)) + call pargi (TM_MIN(time)) + call pargi (TM_SEC(time)) + } else { + call sprintf (datestr, szdate, "%02d-%02d-%02d") + call pargi (TM_MDAY(time)) + call pargi (TM_MONTH(time)) + call pargi (mod (TM_YEAR(time), CENTURY)) + } +end + + +# WFT_FITS_CARD -- Procedure to fetch a single line from a string parameter +# padding it to a maximum of maxcols characters and trimmimg the delim +# character. + +procedure wft_fits_card (instr, ip, card, col_out, maxcols, delim) + +char instr[ARB] # input string +int ip # input string pointer, updated at each call +char card[ARB] # FITS card image +int col_out # pointer to column in card +int maxcols # maximum columns in card +int delim # 1 character string delimiter + +int op + +begin + op = col_out + + # Copy string + while (op <= maxcols && instr[ip] != EOS && instr[ip] != delim) { + card[op] = instr[ip] + ip = ip + 1 + op = op + 1 + } + + # Fill remainder of card with blanks + while (op <= maxcols ) { + card[op] = ' ' + op = op + 1 + } + + if (instr[ip] == delim) + ip = ip + 1 + +end diff --git a/pkg/dataio/fits/fits_read.x b/pkg/dataio/fits/fits_read.x new file mode 100644 index 00000000..f9b0e46c --- /dev/null +++ b/pkg/dataio/fits/fits_read.x @@ -0,0 +1,469 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "rfits.h" + +define MAX_RANGES 100 # the maximum number of ranges + +# RFT_READ_FITZ -- Convert a FITS file. An EOT is signalled by returning EOF. + +int procedure rft_read_fitz (fitsfile, iraffile, pl, file_number) + +char fitsfile[ARB] # FITS file name +char iraffile[ARB] # root IRAF file name +pointer pl # pointer to the file/extensions list +int file_number # the current file number + +bool strne() +int fits_fd, stat, min_lenuserarea, ip, len_elist, oshort_header +int olong_header, ext_count, ext_number, max_extensions, naxes +pointer im, gim, sp, fits, axes, extensions, imname, gimname, gfname, str +pointer himname +int rft_read_header(), mtopen(), immap(), strlen(), envfind(), ctoi() +int rft_ext_skip() +real asumi() +errchk smark, sfree, salloc, rft_read_header, rft_read_image, rft_find_eof() +errchk rft_scan_file, mtopen, immap, imdelete, close, imunmap + +include "rfits.com" + +begin + # Open input FITS data. + fits_fd = mtopen (fitsfile, READ_ONLY, 0) + + # Allocate memory for the FITS data structure and initialize the file + # dependent components of that structure. + call smark (sp) + call salloc (fits, LEN_FITS, TY_STRUCT) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (himname, SZ_FNAME, TY_CHAR) + call salloc (gimname, SZ_FNAME, TY_CHAR) + call salloc (gfname, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Initialize. + SIMPLE(fits) = NO + EXTEND(fits) = NO + GLOBALHDR(fits) = NO + gim = NULL + Memc[gfname] = EOS + + # Determine the length of the user area. + if (envfind ("min_lenuserarea", Memc[imname], SZ_FNAME) > 0) { + ip = 1 + if (ctoi (Memc[imname], ip, min_lenuserarea) <= 0) + min_lenuserarea = LEN_USERAREA + else + min_lenuserarea = max (LEN_USERAREA, min_lenuserarea) + } else + min_lenuserarea = LEN_USERAREA + + # Store the current values of the header printing options. + olong_header = long_header + oshort_header = short_header + + # Get the extensions list for a given line and count the number of + # extensions files. + call salloc (axes, 2, TY_INT) + call pl_gsize (pl, naxes, Memi[axes], stat) + max_extensions = Memi[axes+1] + call salloc (extensions, max_extensions, TY_INT) + Memi[axes] = 1 + Memi[axes+1] = file_number + call pl_glpi (pl, Memi[axes], Memi[extensions], 1, max_extensions, + PIX_SRC) + len_elist = nint (asumi (Memi[extensions], max_extensions)) + + # Loop over the extensions. + ext_count = 1; stat = BOF + do ext_number = 1, max_extensions { + + if (stat == EOF) + break + if (Memi[extensions+ext_number-1] == 0) + next + + # Locate the next extension to be read. + while (ext_count <= ext_number) { + + # Create the IRAF image header. If only a header listing is + # desired or the image extension is to be skipped then map + # the scratch image onto DEV$NULL (faster than a real file). + # If more than one extension is to be read then append the + # extension number to the input name. + + if (make_image == NO || ext_count != ext_number) { + call strcpy ("dev$null", Memc[imname], SZ_FNAME) + } else if (len_elist > 1 && ext_count == ext_number) { + call sprintf (Memc[imname], SZ_FNAME, "%s%04d") + call pargstr (iraffile) + call pargi (ext_number - 1) + } else + call strcpy (iraffile, Memc[imname], SZ_FNAME) + im = immap (Memc[imname], NEW_IMAGE, min_lenuserarea) + call strcpy (IM_HDRFILE(im), Memc[himname], SZ_FNAME) + + # Skip any extensions the user does not want. In order to do + # this we must read the header to see how big the data array + # to be skipped is. + if (ext_count != ext_number) { + + # Turn off header printing. + long_header = NO + short_header = NO + + # Decode the header and skip the data. + iferr { + stat = rft_read_header (fits_fd, fits, im, gim) + if (stat != EOF) + stat = rft_ext_skip (fits_fd, fits, im) + if (stat == EOF) { + if (ext_count == 1) { + call printf ("File: %s\n") + call pargstr (fitsfile) + } else if (asumi(Memi[extensions], + ext_count - 1) < 1.0) { + call printf ("File: %s\n") + call pargstr (fitsfile) + } + if (ext_count > 1) { + call printf ("Extension: %d End of data\n") + call pargi (ext_count - 1) + } else + call printf (" End of data\n") + } else if (EXTEND(fits) == NO) { + call printf ("File: %s\n") + call pargstr (fitsfile) + call printf ("Extension: 1 End of data\n") + } + } then { + call flush (STDOUT) + call erract (EA_WARN) + } + + # Restore the default header printing values. + long_header = olong_header + short_header = oshort_header + + # Read the extension the user specified. If the extension + # is not the primary data or IMAGE skip the data and + # continue. + } else { + + # Set up for printing a long or a short header. + if (long_header == YES || short_header == YES) { + if (long_header == YES) { + if (ext_number == 1) { + if (make_image == YES) { + call printf ("File: %s Image: %s") + call pargstr (fitsfile) + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + } else { + call printf ("File: %s") + call pargstr (fitsfile) + } + } else if (asumi (Memi[extensions], + ext_number -1) < 1.0) { + if (make_image == YES) { + call printf ( + "File: %s\nExtension: %d Image: %s") + call pargstr (fitsfile) + call pargi (ext_number - 1) + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + } else { + call printf ("File: %s Extension: %d") + call pargstr (fitsfile) + call pargi (ext_number - 1) + } + } else { + if (make_image == YES) { + call printf ("Extension: %d Image: %s") + call pargi (ext_number - 1) + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + } else { + call printf ("File: %s Extension: %d") + call pargstr (fitsfile) + call pargi (ext_number - 1) + } + } + } else { + if (ext_number == 1) { + call printf ("File: %s ") + call pargstr (fitsfile) + } else if (asumi (Memi[extensions], + ext_number - 1) < 1.0) { + call printf ("File: %s\nExtension: %d ") + call pargstr (fitsfile) + call pargi (ext_number - 1) + } else { + call printf ("Extension: %d ") + call pargi (ext_number - 1) + } + } + if (long_header == YES) + call printf ("\n") + } + call flush (STDOUT) + + # Read header. EOT is signalled by an EOF status from + # fits_read_header. Create an IRAF image if desired. + + iferr { + stat = rft_read_header (fits_fd, fits, im, gim) + if (stat == EOF) { + call printf ("End of data\n") + } else if (make_image == YES) { + if (XTENSION(fits) == EXT_PRIMARY || + XTENSION(fits) == EXT_IMAGE) { + call rft_read_image (fits_fd, fits, im) + } else if (EXTEND(fits) == YES) { + stat = rft_ext_skip (fits_fd, fits, im) + if (stat == EOF) + call printf ("End of data\n") + } else if (EXTEND(fits) == NO && fe > 0.0) { + call rft_find_eof (fits_fd) + } + } else { + if (EXTEND(fits) == YES) { + stat = rft_ext_skip (fits_fd, fits, im) + if (stat == EOF) + call printf ("End of data\n") + } else if (EXTEND(fits) == NO && fe > 0.0) + call rft_scan_file (fits_fd, fits, im, fe) + } + } then { + call flush (STDOUT) + call erract (EA_WARN) + } + } + + + # Deal with the global header issue. Save the global header + # file name for possible future use. + if (GLOBALHDR(fits) == YES) { + if (gim == NULL && XTENSION(fits) == EXT_PRIMARY) { + call mktemp ("tmp$", Memc[gimname], SZ_FNAME) + gim = immap (Memc[gimname], NEW_COPY, im) + call strcpy (IRAFNAME(fits), Memc[gfname], SZ_FNAME) + } else if (IRAFNAME(fits) == EOS) + call strcpy (Memc[gfname], IRAFNAME(fits), SZ_FNAME) + + } + + # Close the output image. + call imunmap (im) + + # Optionally restore the old IRAF name. + if (stat == EOF) { + call imdelete (Memc[imname]) + break + } else if (make_image == NO || ext_number != ext_count) { + call imdelete (Memc[imname]) + } else if (XTENSION(fits) != EXT_PRIMARY && XTENSION(fits) != + EXT_IMAGE) { + call imdelete (Memc[imname]) + if (XTENSION(fits) != EXT_SPECIAL && ext_count == + ext_number) + call printf (" Skipping non-image data\n") + } else if (old_name == YES && strlen (IRAFNAME(fits)) != 0) { + iferr { + call imgimage (IRAFNAME(fits), IRAFNAME(fits), SZ_FNAME) + call imrename (Memc[imname], IRAFNAME(fits)) + } then { + if (len_elist > 1) { + call sprintf (Memc[str], SZ_FNAME, ".%d") + call pargi (ext_number - 1) + call strcat (Memc[str], IRAFNAME(fits), SZ_FNAME) + iferr (call imrename (Memc[imname], + IRAFNAME(fits))) { + call printf ( + " Cannot rename image %s to %s\n") + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + call pargstr (IRAFNAME(fits)) + call flush (STDOUT) + call erract (EA_WARN) + } else { + call printf (" Image %s renamed to %s\n") + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + call pargstr (IRAFNAME(fits)) + } + } else { + call printf (" Cannot rename image %s to %s\n") + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + call pargstr (IRAFNAME(fits)) + call flush (STDOUT) + call erract (EA_WARN) + } + } else { + call printf (" Image %s renamed to %s\n") + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + call pargstr (IRAFNAME(fits)) + } + } else if (EXTEND(fits) == NO && strne (Memc[imname], + iraffile)) { + iferr { + call imrename (Memc[imname], iraffile) + } then { + call printf (" Cannot rename image %s to %s\n") + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + call pargstr (iraffile) + call flush (STDOUT) + call erract (EA_WARN) + } else { + call printf ( + " No FITS extensions Image renamed to %s\n") + #call pargstr (Memc[imname]) + call pargstr (iraffile) + } + } + + if (EXTEND(fits) == YES && XTENSION(fits) == EXT_PRIMARY && + len_elist == 1 && ext_number == 1) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ( + "Warning: FITS extensions may be present\n") + } + } + if (long_header == YES) + call printf ("\n") + + ext_count = ext_count + 1 + if (EXTEND(fits) == NO || XTENSION(fits) == EXT_SPECIAL) + break + } + + if (EXTEND(fits) == NO || XTENSION(fits) == EXT_SPECIAL) + break + } + + if (gim != NULL) { + call imunmap (gim) + call imdelete (Memc[gimname]) + } + call close (fits_fd) + call sfree (sp) + + if (ext_count == 1) + return (EOF) + else + return (OK) +end + + +# RFT_FIND_EOF -- Read the FITS data file until EOF is reached. + +procedure rft_find_eof (fd) + +int fd # the FITS file descriptor + +int szbuf +pointer sp, buf +int fstati(), read() +errchk read + +begin + # Scan through the file. + szbuf = fstati (fd, F_BUFSIZE) + call smark (sp) + call salloc (buf, szbuf, TY_CHAR) + while (read (fd, Memc[buf], szbuf) != EOF) + ; + call sfree (sp) +end + + +# RFT_SCAN_FILE -- Determine whether it is more efficient to read the +# entire file or to skip forward to the next file if the parameter +# make_image was set to no. + +procedure rft_scan_file (fd, fits, im, fe) + +int fd # the FITS file descriptor +pointer fits # pointer to the FITS descriptor +pointer im # pointer to the output image +real fe # maximum file size in Kb for scan mode + +int i, szbuf +pointer sp, buf +real file_size +int fstati(), read() +errchk read + +begin + # Compute the file size in Kb and return if it is bigger than fe. + file_size = 1.0 + do i = 1, IM_NDIM(im) + file_size = file_size * IM_LEN(im,i) + if (IM_NDIM(im) <= 0) + file_size = 0.0 + else + file_size = file_size * abs (BITPIX(fits)) / FITS_BYTE / 1.0e3 + if (file_size >= fe) + return + + # Scan through the file. + szbuf = fstati (fd, F_BUFSIZE) + call smark (sp) + call salloc (buf, szbuf, TY_CHAR) + while (read (fd, Memc[buf], szbuf) != EOF) + ; + call sfree (sp) +end + + +# RFT_EXT_SKIP -- Compute the size of the data extension to be skipped +# and do the skipping. + +int procedure rft_ext_skip (fits_fd, fits, im) + +int fits_fd # fits file descriptor +pointer fits # pointer to the fits structure +pointer im # pointer to the output image + +int i, nbits, nblocks, sz_rec, blksize, stat +pointer buf +int fstati(), rft_getbuf() + +begin + # Compute the number of blocks to skip. + nbits = NAXISN(im,1) + do i = 2, NAXIS(im) + nbits = nbits * NAXISN(im,i) + nbits = nbits + PCOUNT(fits) + nbits = abs (BITPIX(fits)) * GCOUNT(fits) * nbits + nblocks = int ((nbits + 23039) / 23040) + + sz_rec = FITS_RECORD / SZB_CHAR + call malloc (buf, sz_rec, TY_CHAR) + blksize = fstati (fits_fd, F_SZBBLK) + if (mod (blksize, FITS_RECORD) == 0) + blksize = blksize / FITS_RECORD + else + blksize = 1 + + # Skip the blocks. + do i = 1, nblocks { + stat = rft_getbuf (fits_fd, Memc[buf], sz_rec, blksize, + NRECORDS(fits)) + if (stat == EOF) + break + } + + call mfree (buf, TY_CHAR) + + return (stat) +end diff --git a/pkg/dataio/fits/fits_rheader.x b/pkg/dataio/fits/fits_rheader.x new file mode 100644 index 00000000..e15a3559 --- /dev/null +++ b/pkg/dataio/fits/fits_rheader.x @@ -0,0 +1,888 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "rfits.h" + +define NEPSILON 10.0d0 # number of machine epsilon + +# RFT_READ_HEADER -- Read a FITS header. +# If BSCALE and BZERO are different from 1.0 and 0.0 scale is set to true +# otherwise scale is false. +# EOT is detected by an EOF on the first read and EOF is returned to the calling +# routine. Any error is passed to the calling routine. + +int procedure rft_read_header (fits_fd, fits, im, gim) + +int fits_fd # FITS file descriptor +pointer fits # FITS data structure +pointer im # IRAF image descriptor +pointer gim # IRAF global header image descriptor + +int i, stat, nread, max_lenuser, fd_usr, ndiscard +char card[LEN_CARD+1], type_str[LEN_TYPESTR] +int rft_decode_card(), rft_init_read_pixels(), rft_read_pixels(), strmatch() +int stropen() +errchk rft_decode_card, rft_init_read_pixels, rft_read_pixels +errchk stropen, close + +include "rfits.com" + +begin + # Initialization. + XTENSION(fits) = EXT_PRIMARY + BITPIX(fits) = INDEFI + NAXIS(im) = 0 + do i = 1, IM_MAXDIM + IM_LEN(im,i) = 0 + PCOUNT(fits) = 0 + GCOUNT(fits) = 1 + SCALE(fits) = NO + FITS_BSCALE(fits) = 1.0d0 + FITS_BZERO(fits) = 0.0d0 + BLANKS(fits) = NO + BLANK_VALUE(fits) = INDEFL + NRECORDS(fits) = 0 + IRAFNAME(fits) = EOS + INHERIT(fits) = NO + ndiscard = 0 + OBJECT(im) = EOS + UNKNOWN(im) = EOS + max_lenuser = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + + # The FITS header is character data in FITS_BYTE form. Open the + # header for reading. Open the user area which is a character + # string as a file. + + i = rft_init_read_pixels (len_record, FITS_BYTE, LSBF, TY_CHAR) + fd_usr = stropen (UNKNOWN(im), max_lenuser, NEW_FILE) + + # Loop until the END card is encountered. + nread = 0 + repeat { + + # Read the card. + i = rft_read_pixels (fits_fd, card, LEN_CARD, NRECORDS(fits), 1) + card[LEN_CARD + 1] = '\n' + card[LEN_CARD + 2] = EOS + + # Decode the card images. + if ((i == EOF) && (nread == 0)) { + call close (fd_usr) + return (EOF) + } else if ((nread == 0) && SIMPLE(fits) == NO && + strmatch (card, "^SIMPLE ") == 0) { + call flush (STDOUT) + call close (fd_usr) + call error (30, + "RFT_READ_HEADER: Not a FITS file (no SIMPLE keyword)") + } else if ((nread == 0) && EXTEND(fits) == YES && + strmatch (card, "^XTENSION") == 0) { + XTENSION(fits) = EXT_SPECIAL + call flush (STDOUT) + call close (fd_usr) + call error (30, + "RFT_READ_HEADER: Not a FITS extension (no XTENSION keyword)") + } else if (i != LEN_CARD) { + call close (fd_usr) + call error (2, "RFT_READ_HEADER: Error reading FITS header") + } else + nread = nread + 1 + + # Remove contaminating control characters and replace with blanks. + call rft_control_to_blank (card, card, LEN_CARD) + + # Print FITS card images if long_header option specified. + if (long_header == YES) { + call printf ("%-80.80s\n") + call pargstr (card) + } + + # Stat = YES if FITS END card is encountered. + stat = rft_decode_card (fits, im, fd_usr, card, ndiscard) + + } until (stat == YES) + + # Check for the possibility of a global header. + if (NAXIS(im) == 0 && XTENSION(fits) == EXT_PRIMARY) + GLOBALHDR(fits) = YES + + # Set the output image pixel type. + call rft_set_image_pixtype (fits, im, FITS_BSCALE(fits), + FITS_BZERO(fits)) + + # Copy the global header title and user area into the output image. + if (GLOBALHDR(fits) == YES) { + if (XTENSION(fits) == EXT_IMAGE && INHERIT(fits) == YES && + gim != NULL) { + if (OBJECT(im) == EOS) + call strcpy (OBJECT(gim), OBJECT(im), SZ_OBJECT) + call close (fd_usr) + fd_usr = stropen (UNKNOWN(im), max_lenuser, APPEND) + call rft_gheader (im, gim, fd_usr, card, LEN_CARD, ndiscard, + long_header) + } + } + + # Print optional short header. + if (short_header == YES && long_header == NO) { + call printf ("%s ") + switch (XTENSION(fits)) { + case EXT_PRIMARY: + call pargstr ("") + case EXT_IMAGE: + call pargstr ("IMAGE") + case EXT_TABLE: + call pargstr ("TABLE") + case EXT_BINTABLE: + call pargstr ("BINTABLE") + case EXT_UNKNOWN: + call pargstr ("UNKNOWN") + default: + call pargstr ("UNDEFINED") + } + if (make_image == NO) { + if (old_name == YES) { + call printf ("-> %s ") + call pargstr (IRAFNAME(fits)) + } + } else { + call printf ("-> %s ") + call pargstr (IM_HDRFILE(im)) + } + call printf ("%-20.20s ") + call pargstr (OBJECT(im)) + call printf ("size=") + if (NAXIS(im) == 0) + call printf ("0") + else { + do i = 1, NAXIS(im) { + if (i == 1) { + call printf ("%d") + call pargl (NAXISN(im,i)) + } else { + call printf ("x%d") + call pargl (NAXISN(im,i)) + } + } + } + call printf ("\n") + if (XTENSION(fits) == EXT_PRIMARY || XTENSION(fits) == EXT_IMAGE) { + call printf (" bitpix=%d") + call pargi (BITPIX(fits)) + if (SCALE(fits) == NO) { + call printf (" scaling=none") + } else { + call printf (" bscale=%.7g bzero=%.7g") + call pargd (FITS_BSCALE(fits)) + call pargd (FITS_BZERO(fits)) + } + call rft_typestring (PIXTYPE(im), type_str, LEN_TYPESTR) + call strlwr (type_str) + call printf (" pixtype=%s") + call pargstr (type_str) + call printf ("\n") + } + } + + # Let the user know if there is not enough space in the user area. + if (ndiscard > 0) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ( + "Warning: User area too small %d card images discarded\n") + call pargi (ndiscard) + } + call rft_last_user (UNKNOWN(im), max_lenuser) + } + + call close (fd_usr) + return (OK) +end + + +# RFT_CONTROL_TO_BLANK -- Replace an ACSII control characters in the +# FITS card image with blanks. + +procedure rft_control_to_blank (incard, outcard, len_card) + +char incard[ARB] # the input FITS card image +char outcard[ARB] # the output FITS card image +int len_card # the length of the FITS card image + +int i + +begin + for (i = 1; i <= len_card; i = i + 1) { + if (IS_PRINT(incard[i])) + outcard[i] = incard[i] + else + outcard[i] = ' ' + } +end + + +# RFT_DECODE_CARD -- Decode a FITS card and return YES when the END +# card is encountered. The keywords understood are given in rfits.h. + +int procedure rft_decode_card (fits, im, fd_usr, card, ndiscard) + +pointer fits # FITS data structure +pointer im # IRAF image descriptor +int fd_usr # file descriptor of user area +char card[ARB] # FITS card +int ndiscard # Number of cards for which no space available + +char cval +double dval +int nchar, i, j, k, len +pointer sp, str, comment + +bool rft_equald() +int strmatch(), ctoi(), ctol(), ctod(), cctoc(), rft_hms() +errchk putline + +include "rfits.com" + +begin + call smark (sp) + call salloc (str, LEN_CARD, TY_CHAR) + call salloc (comment, SZ_LINE, TY_CHAR) + + i = COL_VALUE + if (strmatch (card, "^END ") != 0) { + call sfree (sp) + return(YES) + } else if (strmatch (card, "^SIMPLE ") != 0) { + if (SIMPLE(fits) == YES) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate SIMPLE keyword ignored\n") + } + } else { + nchar = cctoc (card, i, cval) + if (cval != 'T') + call error (13, "RFT_DECODE_CARD: Non-standard FITS format") + else + SIMPLE(fits) = YES + } + } else if (strmatch (card, "^XTENSION") != 0) { + call rft_get_fits_string (card, Memc[str], LEN_CARD) + if (strmatch (Memc[str], "^IMAGE") != 0) + XTENSION(fits) = EXT_IMAGE + else if (strmatch (Memc[str], "^TABLE") != 0) + XTENSION(fits) = EXT_TABLE + else if (strmatch (Memc[str], "^BINTABLE") != 0) + XTENSION(fits) = EXT_BINTABLE + else + XTENSION(fits) = EXT_UNKNOWN + } else if (strmatch (card, "^BITPIX ") != 0) { + if (! IS_INDEFI(BITPIX(fits))) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate BITPIX keyword ignored\n") + } + } else + nchar = ctoi (card, i, BITPIX(fits)) + } else if (strmatch (card, "^NAXIS ") != 0) { + if (NAXIS(im) != 0) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate NAXIS keyword ignored\n") + } + } else + nchar = ctoi (card, i, NAXIS(im)) + if (NAXIS(im) > IM_MAXDIM) + call error (5, "RFT_DECODE_CARD: FITS NAXIS too large") + } else if (strmatch (card, "^NAXIS") != 0) { + k = strmatch (card, "^NAXIS") + nchar = ctoi (card, k, j) + if (NAXISN(im,j) != 0) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate NAXIS%d keyword ignored\n") + call pargi (j) + } + } else + nchar = ctol (card, i, NAXISN(im, j)) + } else if (strmatch (card, "^GROUPS ") != 0) { + nchar = cctoc (card, i, cval) + if (cval == 'T') { + NAXIS(im) = 0 + call error (6, "RFT_DECODE_CARD: Group data not implemented") + } + } else if (strmatch (card, "^EXTEND ") != 0) { + if (EXTEND(fits) == YES) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate EXTEND keyword ignored\n") + } + } else { + nchar = cctoc (card, i, cval) + if (cval == 'T') + EXTEND(fits) = YES + } + } else if (strmatch (card, "^INHERIT ") != 0) { + if (INHERIT(fits) == YES) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate INHERIT keyword ignored\n") + } + } else { + nchar = cctoc (card, i, cval) + if (cval == 'T') + INHERIT(fits) = YES + } + } else if (strmatch (card, "^PCOUNT ") != 0) { + nchar = ctoi (card, i, PCOUNT(fits)) + if (nchar <= 0) + PCOUNT(fits) = 0 + } else if (strmatch (card, "^GCOUNT ") != 0) { + nchar = ctoi (card, i, GCOUNT(fits)) + if (nchar <= 0) + GCOUNT(fits) = 1 + #} else if (strmatch (card, "^TABLES ") != 0) { + #nchar = ctoi (card, i, ival) + #if (ival > 0) + #call printf ("Warning: FITS special records not decoded\n") + } else if (strmatch (card, "^BSCALE ") != 0) { + nchar = ctod (card, i, dval) + if (nchar > 0) + FITS_BSCALE(fits) = dval + else if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Error decoding BSCALE, BSCALE=1.0\n") + } + if (! rft_equald (dval, 1.0d0) && (scale == YES)) + SCALE(fits) = YES + } else if (strmatch (card, "^BZERO ") != 0) { + nchar = ctod (card, i, dval) + if (nchar > 0) + FITS_BZERO(fits) = dval + else if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Error decoding BZERO, BZERO=0.0\n") + } + if (! rft_equald (dval, 0.0d0) && (scale == YES)) + SCALE(fits) = YES + } else if (strmatch (card, "^BLANK ") != 0) { + BLANKS(fits) = YES + nchar = ctol (card, i, BLANK_VALUE(fits)) + } else if (strmatch (card, "^OBJECT ") != 0) { + call rft_get_fits_string (card, OBJECT(im), SZ_OBJECT) + } else if (strmatch (card, "^IRAFNAME") != 0) { + call rft_get_fits_string (card, IRAFNAME(fits), SZ_FNAME) + } else if (strmatch (card, "^FILENAME") != 0) { + if (IRAFNAME(fits) == EOS) + call rft_get_fits_string (card, IRAFNAME(fits), SZ_FNAME) + } else if (strmatch (card, "^EXTNAME ") != 0) { + if (XTENSION(fits) != EXT_PRIMARY && XTENSION(fits) != EXT_IMAGE) + call rft_get_fits_string (card, IRAFNAME(fits), SZ_FNAME) + } else if (strmatch (card, "^EXTVER ") != 0) { + # Filter this quantitity out and ignore it for now. + ; + } else if (strmatch (card, "^ORIGIN ") != 0) { + call rft_trim_card (card, card, LEN_CARD) + call strcat (card[i], HISTORY(im), SZ_HISTORY) + } else if (strmatch (card, "^DATE ") != 0) { + call rft_trim_card (card, card, LEN_CARD) + call strcat (card[i], HISTORY(im), SZ_HISTORY) + } else if (strmatch (card, "^IRAF-TLM") != 0) { + call rft_trim_card (card, card, LEN_CARD) + call strcat (card[i], HISTORY(im), SZ_HISTORY) + #} else if (strmatch (card, "^HISTORY ") != 0) { + #call rft_trim_card (card, card, LEN_CARD) + #call strcat (card[i - 2], HISTORY(im), SZ_HISTORY) + } else if (strmatch (card, "^UT ") != 0) { + len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) + if (len > 0) { + call wft_encodec ("UT", Memc[str], len, card, Memc[comment]) + card[LEN_CARD+1] = '\n' + card[LEN_CARD+2] = EOS + } + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } else if (strmatch (card, "^ZD ") != 0) { + len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) + if (len > 0) { + call wft_encodec ("ZD", Memc[str], len, card, Memc[comment]) + card[LEN_CARD+1] = '\n' + card[LEN_CARD+2] = EOS + } + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } else if (strmatch (card, "^ST ") != 0) { + len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) + if (len > 0) { + call wft_encodec ("ST", Memc[str], len, card, Memc[comment]) + card[LEN_CARD+1] = '\n' + card[LEN_CARD+2] = EOS + } + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } else if (strmatch (card, "^RA ") != 0) { + len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) + if (len > 0) { + call wft_encodec ("RA", Memc[str], len, card, Memc[comment]) + card[LEN_CARD+1] = '\n' + card[LEN_CARD+2] = EOS + } + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } else if (strmatch (card, "^DEC ") != 0) { + len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) + if (len > 0) { + call wft_encodec ("DEC", Memc[str], len, card, Memc[comment]) + card[LEN_CARD+1] = '\n' + card[LEN_CARD+2] = EOS + } + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } else { + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } + + call sfree (sp) + + return (NO) + +end + + +# RFT_HMS -- Procedure to decode a FITS HMS card from the mountain. + +int procedure rft_hms (card, str, comment, maxch) + +char card[ARB] # FITS card +char str[ARB] # string +char comment[ARB] # comment string +int maxch # maximum number of characters + +char colon, minus +int ip, nchar, fst, lst, deg, min +real sec +int stridx(), strldx(), strlen(), ctoi(), ctor() + +begin + # Return if not a FITS string parameter. + if (card[COL_VALUE] != '\'') + return (0) + + # Set up key characters. + colon = ':' + minus = '-' + + # Get the FITS string. + call rft_get_fits_string (card, str, maxch) + + # Get the comment string. + call rft_get_comment (card, comment, maxch) + + # Test for blank string and for 2 colon delimiters. + if (str[1] == EOS) + return (0) + fst = stridx (colon, str) + if (fst == 0) + return (0) + lst = strldx (colon, str) + if (lst == 0) + return (0) + if (fst == lst) + return (0) + + # Decode the degrees field. + ip = 1 + while (IS_WHITE(str[ip])) + ip = ip + 1 + if (str[ip] == '+' || str[ip] == '-') + ip = ip + 1 + nchar = ctoi (str, ip, deg) + if (nchar == 0) + deg = 0 + + # Decode the minutes field. + ip = fst + 1 + while (IS_WHITE(str[ip])) + ip = ip + 1 + if (str[ip] == '+' || str[ip] == '-') + ip = ip + 1 + nchar = ctoi (str, ip, min) + if (nchar == 0) + min = 0 + + # Decode the seconds field. + ip = lst + 1 + while (IS_WHITE(str[ip])) + ip = ip + 1 + if (str[ip] == '+' || str[ip] == '-') + ip = ip + 1 + nchar = ctor (str, ip, sec) + if (nchar == 0) + sec = 0.0 + + # Reformat the HMS card. + if (stridx (minus, str) > 0 || deg < 0 || min < 0 || sec < 0.0) { + call sprintf (str, maxch, "%c%d:%02d:%05.2f") + call pargc (minus) + call pargi (abs (deg)) + call pargi (abs (min)) + call pargr (abs (sec)) + } else { + call sprintf (str, maxch, "%2d:%02d:%05.2f") + call pargi (deg) + call pargi (abs (min)) + call pargr (abs (sec)) + } + + return (strlen (str)) +end + + +# RFT_GET_COMMENT -- Extract the comment field from a FITS card. + +procedure rft_get_comment (card, comment, maxch) + +char card[ARB] # FITS card +char comment[ARB] # comment string +int maxch # maximum number of characters + +int istart, j + +begin + istart = 0 + for (j = LEN_CARD; (j >= 1) && (card[j] != '\''); j = j - 1) { + if (card[j] == '/') { + for (istart = j + 1; IS_WHITE(card[istart]) && istart <= + LEN_CARD; istart = istart + 1) + ; + break + } + } + + if (istart == 0) + comment[1] = EOS + else + call strcpy (card[istart], comment, LEN_CARD - istart + 1 ) +end + + +# RFT_GET_FITS_STRING -- Extract a string from a FITS card and trim trailing +# blanks. The EOS is marked by either ', /, or the end of the card. +# There may be an optional opening ' (FITS standard). + +procedure rft_get_fits_string (card, str, maxchar) + +char card[ARB] # FITS card +char str[ARB] # FITS string +int maxchar # maximum number of characters + +int j, istart, nchar + +begin + # Check for opening quote + for (istart = COL_VALUE; istart <= LEN_CARD && card[istart] != '\''; + istart = istart + 1) + ; + istart = istart + 1 + + # Check for closing quote. + for (j = istart; (j= istart) && (card[j] == ' '); j = j - 1) + ; + nchar = min (maxchar, j - istart + 1) + + # Copy the string. + if (nchar <= 0) + str[1] = EOS + else + call strcpy (card[istart], str, nchar) +end + + +# RFT_EQUALD -- Procedure to compare two double precision numbers for equality +# to within the machine precision for doubles. + +bool procedure rft_equald (x, y) + +double x, y # the two numbers to be compared for equality + +int ex, ey +double x1, x2, normed_x, normed_y + +begin + if (x == y) + return (true) + + call rft_normd (x, normed_x, ex) + call rft_normd (y, normed_y, ey) + + if (ex != ey) + return (false) + else { + x1 = 1.0d0 + abs (normed_x - normed_y) + x2 = 1.0d0 + NEPSILON * EPSILOND + return (x1 <= x2) + } +end + + +# RFT_NORMED -- Normalize a double precision number x to the value normed_x, +# in the range [1-10]. Expon is returned such that x = normed_x * +# (10.0d0 ** expon). + +procedure rft_normd (x, normed_x, expon) + +double x # number to be normailized +double normed_x # normalized number +int expon # exponent + +double ax + +begin + ax = abs (x) + expon = 0 + + if (ax > 0) { + while (ax < (1.0d0 - NEPSILON * EPSILOND)) { + ax = ax * 10.0d0 + expon = expon - 1 + } + + while (ax >= (10.0d0 - NEPSILON * EPSILOND)) { + ax = ax / 10.0d0 + expon = expon + 1 + } + } + + if (x < 0) + normed_x = -ax + else + normed_x = ax +end + + +# RFT_TRIM_CARD -- Procedure to trim trailing whitespace from the card + +procedure rft_trim_card (incard, outcard, maxch) + +char incard[ARB] # input FITS card image +char outcard[ARB] # output FITS card +int maxch # maximum size of card + +int ip + +begin + ip = maxch + while (incard[ip] == ' ' || incard[ip] == '\t' || incard[ip] == '\0') + ip = ip - 1 + call amovc (incard, outcard, ip) + outcard[ip+1] = '\n' + outcard[ip+2] = EOS +end + + +# RFT_LAST_CARD -- Remove a partially written card from the data base + +procedure rft_last_user (user, maxch) + +char user[ARB] # user area +int maxch # maximum number of characters + +int ip + +begin + ip = maxch + while (user[ip] != '\n') + ip = ip - 1 + user[ip+1] = EOS +end + + +# RFT_SET_IMAGE_PIXTYPE -- Set remaining header fields not set in +# rft_read_header. + +procedure rft_set_image_pixtype (fits, im, bscale, bzero) + +pointer fits # FITS data structure +pointer im # IRAF image pointer +double bscale # FITS scaling parameter +double bzero # FITS offset parameter + +bool rft_equald() +include "rfits.com" + +begin + # Determine data type from BITPIX if user data type not specified. + + if (data_type == ERR) { + if (BITPIX(fits) < 0) { + if (abs (BITPIX(fits)) <= (SZ_REAL * SZB_CHAR * NBITS_BYTE)) + PIXTYPE(im) = TY_REAL + else + PIXTYPE(im) = TY_DOUBLE + } else if (SCALE(fits) == YES) { + if (rft_equald (bscale, 1.0d0)) { + if (rft_equald (bzero / 32768.0d0, 1.0d0)) + PIXTYPE(im) = TY_USHORT + else + PIXTYPE(im) = TY_REAL + } else + PIXTYPE(im) = TY_REAL + } else { + if (BITPIX(fits) <= (SZ_SHORT * SZB_CHAR * NBITS_BYTE)) + PIXTYPE(im) = TY_SHORT + else + PIXTYPE(im) = TY_LONG + } + + } else + PIXTYPE(im) = data_type +end + + +# Copy the global header into the output image header. + +procedure rft_gheader (im, gim, fd_usr, card, len_card, ndiscard, long_header) + +pointer im # IRAF image header descriptor +pointer gim # IRAF global image header descriptor +int fd_usr # IRAF image header user area +char card[ARB] # FITS card +int len_card # length of FITS card +int ndiscard # number of cards discarded +int long_header # print the long header + +int ngcards, gim_lenuser, ninherit, count +pointer sp, indices, idb_gim, grp, irp +bool streq() +int strlen(), idb_nextcard(), idb_find() +pointer idb_open() +errchk putline() + +begin + # Initialize. + call smark (sp) + ngcards = strlen (UNKNOWN(gim)) / (len_card + 1) + call salloc (indices, ngcards, TY_INT) + + # Mark the global header cards which are to be inherited. These + # include all COMMENT, HISTORY, and BLANK cards, plus all those + # cards which do not already have values in the extension header. + count = 0 + idb_gim = idb_open (gim, gim_lenuser) + while (idb_nextcard (idb_gim, grp) != EOF) { + if (count >= ngcards) + break + call strcpy (Memc[grp], card, 8) + if (streq (card, "COMMENT ")) + Memi[indices+count] = YES + else if (streq (card, "HISTORY ")) + Memi[indices+count] = YES + else if (streq (card, " ")) + Memi[indices+count] = YES + else if (idb_find (im, card, irp) > 0) + Memi[indices+count] = NO + else + Memi[indices+count] = YES + count = count + 1 + } + call idb_close (idb_gim) + + # Open the global header image user area and loop through the cards. + ninherit = 0 + count = 0 + idb_gim = idb_open (gim, gim_lenuser) + while (idb_nextcard (idb_gim, grp) != EOF) { + if (Memi[indices+count] == YES) { + call strcpy (Memc[grp], card, len_card) + card[len_card+1] = '\n' + card[len_card+2] = EOS + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + else + ninherit = ninherit + 1 + } + } + count = count + 1 + } + call idb_close (idb_gim) + + if (long_header == YES) { + call printf ("%d global header keywords were inherited\n") + call pargi (ninherit) + } + + call sfree (sp) +end + + +# RFT_TYPESTRING -- Procedure to set the iraf datatype keyword. + +procedure rft_typestring (data_type, type_str, maxch) + +int data_type # the IRAF data type +char type_str[ARB] # the output IRAF type string +int maxch # maximum size of the type string + +begin + switch (data_type) { + case TY_SHORT: + call strcpy ("SHORT", type_str, maxch) + case TY_USHORT: + call strcpy ("USHORT", type_str, maxch) + case TY_INT: + call strcpy ("INTEGER", type_str, maxch) + case TY_LONG: + call strcpy ("LONG", type_str, maxch) + case TY_REAL: + call strcpy ("REAL", type_str, maxch) + case TY_DOUBLE: + call strcpy ("DOUBLE", type_str, maxch) + case TY_COMPLEX: + call strcpy ("COMPLEX", type_str, maxch) + default: + call strcpy ("UNKNOWN", type_str, maxch) + } +end + + diff --git a/pkg/dataio/fits/fits_rimage.x b/pkg/dataio/fits/fits_rimage.x new file mode 100644 index 00000000..9994c1d4 --- /dev/null +++ b/pkg/dataio/fits/fits_rimage.x @@ -0,0 +1,557 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "rfits.h" + +# RFT_READ_IMAGE -- Convert FITS image pixels to IRAF image pixels. + +procedure rft_read_image (fits_fd, fits, im) + +int fits_fd # FITS file descriptor +pointer fits # FITS data structure +pointer im # IRAF image descriptor + +int i, npix, npix_record, blksize, ndummy +long v[IM_MAXDIM], nlines, il +pointer tempbuf, buf +real linemax, linemin, lirafmin, lirafmax +double dblank + +long clktime() +int fstati(), rft_init_read_pixels(), rft_read_pixels() + +errchk malloc, mfree, rft_init_read_pixels, rft_read_pixels, rft_lscale_pix +errchk rft_lchange_pix, rft_rchange_pix, rfit_dchange_pix, rft_put_image_line +errchk rft_pix_limits, rft_rscale_pix, rft_dscale_pix + +include "rfits.com" + +begin + # No pixel file was created. + if (NAXIS(im) == 0) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: No pixel file created\n") + } + return + } + + # Compute the number of columns and lines in the image. + npix = NAXISN(im, 1) + nlines = 1 + do i = 2, NAXIS(im) + nlines = nlines * NAXISN(im, i) + lirafmax = -MAX_REAL + lirafmin = MAX_REAL + + # Compute the number of pixels per record and the number of records + # per output block. + + npix_record = len_record * FITS_BYTE / abs (BITPIX(fits)) + blksize = fstati (fits_fd, F_SZBBLK) + if (mod (blksize, FITS_RECORD) == 0) + blksize = blksize / FITS_RECORD + else + blksize = 1 + + # FITS data is converted to type LONG, REAL or DOUBLE. If BITPIX is + # not one of the MII types then rft_read_pixels returns an ERROR. + + call amovkl (long(1), v, IM_MAXDIM) + switch (BITPIX(fits)) { + case FITS_REAL: + + # Allocate temporary space. + call malloc (tempbuf, npix, TY_REAL) + + # Initialize the read. + i = rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, TY_REAL) + + # Turn on the ieee NaN mapping. + call ieesnanr (blank) + call ieemapr (YES, NO) + #call ieezstatr () + NBPIX(im) = 0 + + # Allocate the space for the output line, read in the image + # line, convert from the ieee to native format, and compute the + # minimum and maximum. + + do il = 1, nlines { + call rft_put_image_line (im, buf, v, PIXTYPE(im)) + if (rft_read_pixels (fits_fd, Memr[tempbuf], npix, + NRECORDS(fits), blksize) != npix) + call printf ("Error reading FITS data\n") + if (SCALE(fits) == YES) + call rft_rscale_pix (Memr[tempbuf], buf, npix, + FITS_BSCALE(fits), FITS_BZERO(fits), PIXTYPE(im)) + else + call rft_rchange_pix (Memr[tempbuf], buf, npix, PIXTYPE(im)) + call rft_pix_limits (buf, npix, PIXTYPE(im), linemin, linemax) + lirafmax = max (lirafmax, linemax) + lirafmin = min (lirafmin, linemin) + } + + # Set the number of bad pixels. + call ieestatr (NBPIX(im), ndummy) + + # Free space. + call mfree (tempbuf, TY_REAL) + + case FITS_DOUBLE: + + # Allocate temporary space. + call malloc (tempbuf, npix, TY_DOUBLE) + + # Initialize the read. + i = rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, + TY_DOUBLE) + + # Turn on the ieee NaN mapping. + dblank = blank + call ieesnand (dblank) + call ieemapd (YES, NO) + #call ieezstatd () + NBPIX(im) = 0 + + # Allocate the space for the output line, read in the image + # line, convert from the ieee to native format, and compute the + # minimum and maximum. + + do il = 1, nlines { + call rft_put_image_line (im, buf, v, PIXTYPE(im)) + if (rft_read_pixels (fits_fd, Memd[tempbuf], npix, + NRECORDS(fits), blksize) != npix) + call printf ("Error reading FITS data\n") + if (SCALE(fits) == YES) + call rft_dscale_pix (Memd[tempbuf], buf, npix, + FITS_BSCALE(fits), FITS_BZERO(fits), PIXTYPE(im)) + else + call rft_dchange_pix (Memd[tempbuf], buf, npix, PIXTYPE(im)) + call rft_pix_limits (buf, npix, PIXTYPE(im), linemin, linemax) + if (IS_INDEFR(linemax)) + lirafmax = INDEFR + else + lirafmax = max (lirafmax, linemax) + if (IS_INDEFR(linemin)) + lirafmin = INDEFR + else + lirafmin = min (lirafmin, linemin) + } + + # Set the number of bad pixels. + call ieestatd (NBPIX(im), ndummy) + + # Free space. + call mfree (tempbuf, TY_DOUBLE) + + default: + + # Allocate the required space. + call malloc (tempbuf, npix, TY_LONG) + + # Allocate the space for the output line, read in the image + # line, convert from the ieee to native format, and compute the + # minimum and maximum. + + i = rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, TY_LONG) + do il = 1, nlines { + call rft_put_image_line (im, buf, v, PIXTYPE(im)) + if (rft_read_pixels (fits_fd, Meml[tempbuf], npix, + NRECORDS(fits), blksize) != npix) + call printf ("Error reading FITS data\n") + if (SCALE(fits) == YES) + call rft_lscale_pix (Meml[tempbuf], buf, npix, + FITS_BSCALE(fits), FITS_BZERO(fits), PIXTYPE(im)) + else + call rft_lchange_pix (Meml[tempbuf], buf, npix, PIXTYPE(im)) + if (BLANKS(fits) == YES) + call rft_map_blanks (Meml[tempbuf], buf, npix, PIXTYPE(im), + BLANK_VALUE(fits), blank, NBPIX(im)) + call rft_pix_limits (buf, npix, PIXTYPE(im), linemin, linemax) + lirafmax = max (lirafmax, linemax) + lirafmin = min (lirafmin, linemin) + } + + # Free space. + call mfree (tempbuf, TY_LONG) + } + + IRAFMIN(im) = lirafmin + IRAFMAX(im) = lirafmax + LIMTIME(im) = clktime (long(0)) + + if (short_header == YES || long_header == YES) { + if (NBPIX (im) != 0) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: %d bad pixels replaced in image\n") + call pargl (NBPIX (im)) + } + if (IS_INDEFR(lirafmax) || lirafmax > MAX_REAL) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: image contains pixel values > %g\n") + call pargr (MAX_REAL) + } + if (IS_INDEFR(lirafmin) || lirafmin < -MAX_REAL) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: image contains pixel values < %g\n") + call pargr (-MAX_REAL) + } + } +end + + +# RFT_PUT_IMAGE_LINE -- Procedure to output an image line to and IRAF file. + +procedure rft_put_image_line (im, buf, v, data_type) + +pointer im # IRAF image descriptor +pointer buf # Pointer to output image line +long v[ARB] # imio pointer +int data_type # output pixel type + +int impnll(), impnlr(), impnld(), impnlx() +errchk impnll, impnlr, impnld, impnlx + +begin + switch (data_type) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + if (impnll (im, buf, v) == EOF) + call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") + case TY_REAL: + if (impnlr (im, buf, v) == EOF) + call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") + case TY_DOUBLE: + if (impnld (im, buf, v) == EOF) + call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") + case TY_COMPLEX: + if (impnlx (im, buf, v) == EOF) + call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") + default: + call error (10, "RFT_PUT_IMAGE_LINE: Unsupported IRAF image type") + } +end + + +# RFT_RSCALE_PIX -- Procedure to convert an IRAF image line from type real +# to the requested output data type with optional scaling using the +# FITS parameters BSCALE and BZERO. + +procedure rft_rscale_pix (inbuf, outbuf, npix, bscale, bzero, data_type) + +real inbuf[ARB] # buffer of FITS integers +pointer outbuf # pointer to output image line +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero +int data_type # IRAF image pixel type + +errchk altmdr, achtrl, amovr, achtrd, achtrx + +begin + switch (data_type) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + call altmdr (inbuf, inbuf, npix, bscale, bzero) + call achtrl (inbuf, Meml[outbuf], npix) + case TY_REAL: + call altmdr (inbuf, inbuf, npix, bscale, bzero) + call amovr (inbuf, Memr[outbuf], npix) + case TY_DOUBLE: + call altmdr (inbuf, inbuf, npix, bscale, bzero) + call achtrd (inbuf, Memd[outbuf], npix) + case TY_COMPLEX: + call altmdr (inbuf, inbuf, npix, bscale, bzero) + call achtrx (inbuf, Memx[outbuf], npix) + default: + call error (10, "RFT_SCALE_LINE: Illegal IRAF image type") + } +end + + +# RFT_DSCALE_PIX -- Procedure to convert an IRAF image line from type double +# to the requested output data type with optional scaling using the +# FITS parameters BSCALE and BZERO. + +procedure rft_dscale_pix (inbuf, outbuf, npix, bscale, bzero, data_type) + +double inbuf[ARB] # buffer of FITS integers +pointer outbuf # pointer to output image line +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero +int data_type # IRAF image pixel type + +errchk altmd, achtdl, amovd, achtdr, achtdx + +begin + switch (data_type) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + call altmd (inbuf, inbuf, npix, bscale, bzero) + call achtdl (inbuf, Meml[outbuf], npix) + case TY_REAL: + call altmd (inbuf, inbuf, npix, bscale, bzero) + call achtdr (inbuf, Memr[outbuf], npix) + case TY_DOUBLE: + call altmd (inbuf, inbuf, npix, bscale, bzero) + call amovd (inbuf, Memd[outbuf], npix) + case TY_COMPLEX: + call altmd (inbuf, inbuf, npix, bscale, bzero) + call achtdx (inbuf, Memx[outbuf], npix) + default: + call error (10, "RFT_SCALE_LINE: Illegal IRAF image type") + } +end + + + +# RFT_LSCALE_PIX -- Procedure to convert an IRAF image line from type long +# to the requested output data type with optional scaling using the +# FITS parameters BSCALE and BZERO. + +procedure rft_lscale_pix (inbuf, outbuf, npix, bscale, bzero, data_type) + +long inbuf[ARB] # buffer of FITS integers +pointer outbuf # pointer to output image line +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero +int data_type # IRAF image pixel type + +errchk achtll, achtlr, achtld, achtlx +errchk altml, altmr, altmd, altmx + +begin + switch (data_type) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + call achtll (inbuf, Meml[outbuf], npix) + call altml (Meml[outbuf], Meml[outbuf], npix, bscale, bzero) + case TY_REAL: + call altmlr (inbuf, Memr[outbuf], npix, bscale, bzero) + case TY_DOUBLE: + call achtld (inbuf, Memd[outbuf], npix) + call altmd (Memd[outbuf], Memd[outbuf], npix, bscale, bzero) + case TY_COMPLEX: + call achtlx (inbuf, Memx[outbuf], npix) + call altmx (Memx[outbuf], Memx[outbuf], npix, real (bscale), + real (bzero)) + default: + call error (10, "RFT_SCALE_LINE: Illegal IRAF image type") + } +end + + +# RFT_RCHANGE_PIX -- Procedure to change a line of real numbers to the +# IRAF image type. + +procedure rft_rchange_pix (inbuf, outbuf, npix, data_type) + +real inbuf[ARB] # array of FITS integers +pointer outbuf # pointer to IRAF image line +int npix # number of pixels +int data_type # IRAF pixel type + +errchk achtrl, amovr, achtrd, achtrx + +begin + switch (data_type) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + call achtrl (inbuf, Meml[outbuf], npix) + case TY_REAL: + call amovr (inbuf, Memr[outbuf], npix) + case TY_DOUBLE: + call achtrd (inbuf, Memd[outbuf], npix) + case TY_COMPLEX: + call achtrx (inbuf, Memx[outbuf], npix) + default: + call error (10, "RFT_RCHANGE_LINE: Illegal IRAF image type") + } +end + + +# RFT_DCHANGE_PIX -- Procedure to change a line of double precision numbers +# to the IRAF image type. + +procedure rft_dchange_pix (inbuf, outbuf, npix, data_type) + +double inbuf[ARB] # array of FITS integers +pointer outbuf # pointer to IRAF image line +int npix # number of pixels +int data_type # IRAF pixel type + +errchk achtdl, achtdr, amovd, achtdx + +begin + switch (data_type) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + call achtdl (inbuf, Meml[outbuf], npix) + case TY_REAL: + call achtdr (inbuf, Memr[outbuf], npix) + case TY_DOUBLE: + call amovd (inbuf, Memd[outbuf], npix) + case TY_COMPLEX: + call achtdx (inbuf, Memx[outbuf], npix) + default: + call error (10, "RFT_DCHANGE_LINE: Illegal IRAF image type") + } +end + + + +# RFT_LCHANGE_PIX -- Procedure to change a line of long integers to the +# IRAF image type. + +procedure rft_lchange_pix (inbuf, outbuf, npix, data_type) + +long inbuf[ARB] # array of FITS integers +pointer outbuf # pointer to IRAF image line +int npix # number of pixels +int data_type # IRAF pixel type + +begin + switch (data_type) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + call achtll (inbuf, Meml[outbuf], npix) + case TY_REAL: + call achtlr (inbuf, Memr[outbuf], npix) + case TY_DOUBLE: + call achtld (inbuf, Memd[outbuf], npix) + case TY_COMPLEX: + call achtlx (inbuf, Memx[outbuf], npix) + default: + call error (10, "RFT_CHANGE_LINE: Illegal IRAF image type") + } +end + + +# RFT_MAP_BLANKS -- Map the blank pixels. Currently only the number of blank +# pixels is determined without an further mapping. + +procedure rft_map_blanks (a, buf, npts, pixtype, blank_value, blank, nbadpix) + +long a[ARB] # integer input buffer +pointer buf # pointer to output image buffer +int npts # number of points +int pixtype # image data type +long blank_value # FITS blank value +real blank # user blank value +long nbadpix # number of bad pixels + +int i + +begin + # Do blank mapping here + switch (pixtype) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + do i = 1, npts { + if (a[i] == blank_value) { + nbadpix = nbadpix + 1 + Meml[buf+i-1] = blank + } + } + case TY_REAL: + do i = 1, npts { + if (a[i] == blank_value) { + nbadpix = nbadpix + 1 + Memr[buf+i-1] = blank + } + } + case TY_DOUBLE: + do i = 1, npts { + if (a[i] == blank_value) { + nbadpix = nbadpix + 1 + Memd[buf+i-1] = blank + } + } + case TY_COMPLEX: + do i = 1, npts { + if (a[i] == blank_value) { + nbadpix = nbadpix + 1 + Memx[buf+i-1] = blank + } + } + } +end + + +# RFT_PIX_LIMITS -- Procedure to determine to maxmimum and minimum values in a +# line. Note that double precision is somewhat of a special case because +# MAX_DOUBLE is a lot less than the maximum permitted ieee numbers for iraf. + +procedure rft_pix_limits (buf, npix, pixtype, linemin, linemax) + +pointer buf # pointer to IRAF image line +int npix # number of pixels +int pixtype # output data type +real linemax, linemin # min and max pixel values + +long lmax, lmin +real rmax, rmin +double dmax, dmin +complex xmax, xmin + +begin + switch (pixtype) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + call aliml (Meml[buf], npix, lmin, lmax) + linemax = lmax + linemin = lmin + case TY_REAL: + call alimr (Memr[buf], npix, rmin, rmax) + linemax = rmax + linemin = rmin + case TY_DOUBLE: + call alimd (Memd[buf], npix, dmin, dmax) + if (dmax > MAX_REAL) + linemax = INDEFR + else + linemax = dmax + if (dmin < -MAX_REAL) + linemin = INDEFR + else + linemin = dmin + case TY_COMPLEX: + call alimx (Memx[buf], npix, xmin, xmax) + linemax = xmax + linemin = xmin + default: + call error (30, "RFT_PIX_LIMITS: Unknown IRAF type") + } +end + + +# ALTMDR -- procedure to scale a long vector into a real vector using +# double precision constants to preserve accuracy + +procedure altmlr (a, b, npix, bscale, bzero) + +long a[ARB] # input array +real b[ARB] # output array +int npix # number of pixels +double bscale, bzero # scaling parameters + +int i + +begin + do i = 1, npix + b[i] = a[i] * bscale + bzero +end + + +# ALTMDR -- procedure to scale a real vector with double precision constants. + +procedure altmdr (a, b, npix, bscale, bzero) + +real a[ARB] # input array +real b[ARB] # output array +int npix # number of pixels +double bscale, bzero # scaling parameters + +int i + +begin + do i = 1, npix + b[i] = a[i] * bscale + bzero +end diff --git a/pkg/dataio/fits/fits_rpixels.x b/pkg/dataio/fits/fits_rpixels.x new file mode 100644 index 00000000..6183120d --- /dev/null +++ b/pkg/dataio/fits/fits_rpixels.x @@ -0,0 +1,154 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# RFT_INIT_READ_PIXELS and READ_PIXELS -- Read pixel data with record buffering +# and data type conversion. The input data must meet the MII standard +# except for possibly in the case of integers having the least significant +# byte first. +# +# Read data in records of len_record and convert to the specified IRAF +# data type. Successive calls of rft_read_pixels returns the next npix pixels. +# Read_pixels returns EOF or the number of pixels converted. +# Init_read_pixels must be called before read_pixels. +# +# Error conditions are: +# 1. A short input record +# 2. Error in converting the pixels by miiup. +# +# This routine is based on the MII unpack routine which is machine dependent. +# The bitpix must correspond to an MII type. If the lsbf (least significant +# byte first) flag is YES then the pixels do not satisfy the MII standard. +# In this case the bytes are first swapped into most significant byte first +# before the MII unpack routine is called. + +int procedure rft_init_read_pixels (npix_record, bitpix, lsbf, spp_type) + +int npix_record # number of pixels per input record +int bitpix # bits per pixel (must correspond to an MII type) +int lsbf # byte swap? +int spp_type # SPP data type to be returned + +# entry rft_read_pixels (fd, buffer, npix) + +int rft_read_pixels +int fd # input file descriptor +char buffer[1] # output buffer +int npix # number of pixels to read + +int swap +int ty_mii, ty_spp, npix_rec, nch_rec, sz_rec, nchars, len_mii, recptr +int bufsize, i, n, ip, op +pointer mii, spp + +int rft_getbuf(), sizeof(), miilen() +errchk miilen, mfree, malloc, rft_getbuf, miiupk +data mii/NULL/, spp/NULL/ + +begin + ty_mii = bitpix + ty_spp = spp_type + swap = lsbf + npix_rec = npix_record + nch_rec = npix_rec * sizeof (ty_spp) + + len_mii = miilen (npix_rec, ty_mii) + sz_rec = len_mii * SZ_INT32 + + if (mii != NULL) + call mfree (mii, TY_INT) + call malloc (mii, len_mii, TY_INT) + + if (spp != NULL) + call mfree (spp, TY_CHAR) + call malloc (spp, nch_rec, TY_CHAR) + + ip = nch_rec + return (OK) + +entry rft_read_pixels (fd, buffer, npix, recptr, bufsize) + + nchars = npix * sizeof (ty_spp) + op = 0 + + repeat { + + # If data is exhausted read the next record + if (ip == nch_rec) { + + i = rft_getbuf (fd, Memi[mii], sz_rec, bufsize, recptr) + if (i == EOF) + return (EOF) + + if (swap == YES) + switch (ty_mii) { + case MII_SHORT: + call bswap2 (Memi[mii], 1, Memi[mii], 1, + sz_rec * SZB_CHAR) + case MII_LONG: + call bswap4 (Memi[mii], 1, Memi[mii], 1, + sz_rec * SZB_CHAR) + } + + call miiupk (Memi[mii], Memc[spp], npix_rec, ty_mii, ty_spp) + + ip = 0 + #recptr = recptr + 1 + } + + n = min (nch_rec - ip, nchars - op) + call amovc (Memc[spp+ip], buffer[1+op], n) + ip = ip + n + op = op + n + + } until (op == nchars) + + return (npix) +end + + +# RFT_GETBUF -- Procedure to get the buffer. + +int procedure rft_getbuf (fd, buf, sz_rec, bufsize, recptr) + +int fd # file descriptor +char buf[ARB] # buffer to be filled +int sz_rec # size in chars of record to be read +int bufsize # buffer size in records +int recptr # last successful FITS record read + +int i, nchars +int read(), fstati() +errchk read + +begin + nchars = 0 + repeat { + iferr { + i = read (fd, buf[nchars+1], sz_rec - nchars) + } then { + call printf ("Error reading FITS record %d\n") + if (mod (recptr + 1, bufsize) == 0) + call pargi ((recptr + 1) / bufsize) + else + call pargi ((recptr + 1) / bufsize + 1) + call fseti (fd, F_VALIDATE, fstati (fd, F_SZBBLK) / SZB_CHAR) + i = read (fd, buf[nchars+1], sz_rec - nchars) + } + + if (i == EOF) + break + else + nchars = nchars + i + + } until (nchars >= sz_rec) + + if ((i == EOF) && (nchars == 0)) + return (EOF) + else { + recptr = recptr + 1 + return (nchars) + } +end diff --git a/pkg/dataio/fits/fits_wheader.x b/pkg/dataio/fits/fits_wheader.x new file mode 100644 index 00000000..ec06f968 --- /dev/null +++ b/pkg/dataio/fits/fits_wheader.x @@ -0,0 +1,469 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "wfits.h" + +# WFT_WRITE_HEADER -- Write the FITS headers. The FITS header +# parameters are encoded one by one until the FITS END keyword is detected. +# If the long_header switch is set the full FITS header is printed on the +# standard output. If the short header parameter is specified only the image +# title and dimensions are printed. + +procedure wft_write_header (im, fits, fits_fd) + +pointer im # pointer to the IRAF image +pointer fits # pointer to the FITS structure +int fits_fd # the FITS file descriptor + +char card[LEN_CARD+1], trim_card[LEN_CARD+1] +int nrecords, recntr, cardptr, cardcnt, stat, cards_per_rec, i +int wft_card_encode(), wft_set_bitpix(), sizeof(), strncmp() +int wft_init_card_encode(), fstati() + +errchk wft_set_bitpix, wft_get_iraf_typestring, wft_set_scale, wft_set_blank +errchk wft_fits_set_scale, wft_init_card_encode, wft_card_encode +errchk wft_init_write_pixels, wft_write_pixels, wft_write_last_record + +include "wfits.com" + +begin + # SET the data and FITS bits per pixel. + + DATA_BITPIX(fits) = sizeof (PIXTYPE(im)) * SZB_CHAR * NBITS_BYTE + FITS_BITPIX(fits) = wft_set_bitpix (bitpix, PIXTYPE(im), + DATA_BITPIX(fits)) + + # Calculate the FITS bscale and bzero parameters. Notice for the + # time being that scaling is turned off if IEEE floating point + # output is selected. May decide to change this later after + # checking the specifications. + + if (FITS_BITPIX(fits) < 0) { + + IRAFMIN(fits) = IM_MIN(im) + IRAFMAX(fits) = IM_MAX(im) + SCALE(fits) = NO + BZERO(fits) = 0.0d0 + BSCALE(fits) = 1.0d0 + + } else if (autoscale == YES) { + + call wft_get_tape_limits (FITS_BITPIX(fits), TAPEMIN(fits), + TAPEMAX(fits)) + call wft_data_limits (im, IRAFMIN(fits), IRAFMAX(fits)) + call wft_fits_set_scale (im, DATA_BITPIX(fits), FITS_BITPIX(fits), + IRAFMIN(fits), IRAFMAX(fits), TAPEMIN(fits), TAPEMAX(fits), + SCALE(fits), BSCALE(fits), BZERO(fits)) + + } else { + + IRAFMIN(fits) = IM_MIN(im) + IRAFMAX(fits) = IM_MAX(im) + SCALE(fits) = scale + BZERO(fits) = bzero + BSCALE(fits) = bscale + } + + # If blanks in the image set the blank parameter. Currently information + # on blanks is not written out so this is effectively a null operation + # in IRAF. + + if (NBPIX(im) > 0) + call wft_set_blank (FITS_BITPIX(fits), BLANK(fits), + BLANK_STRING(fits)) + + # Set the IRAF datatype parameter. + call wft_get_iraf_typestring (PIXTYPE(im), TYPE_STRING(fits)) + + # Initialize the card counters. These counters are used only for + # information printed to the standard output. + + recntr = 1 + cardptr = 1 + cardcnt = 1 + cards_per_rec = len_record / LEN_CARD + + # Get set up to write the FITS header. Initialize for an ASCII write. + stat = wft_init_card_encode (im, fits) + if (make_image == YES) + call wft_init_wrt_pixels (len_record, TY_CHAR, FITS_BYTE, blkfac) + + # Print short header. + if (short_header == YES && long_header == NO) { + + call printf ("%-20.20s ") + call pargstr (OBJECT(im)) + do i = 1, NAXIS(im) { + if (i == 1) { + call printf ("Size = %d") + call pargl (NAXISN(im,i)) + } else { + call printf (" x %d") + call pargl (NAXISN(im,i)) + } + } + call printf ("\n") + + call strlwr (TYPE_STRING(fits)) + call printf ("\tpixtype=%s bitpix=%d") + call pargstr (TYPE_STRING(fits)) + call pargi (FITS_BITPIX(fits)) + + if (fstati (fits_fd, F_BLKSIZE) == 0) { + call printf (" blkfac=%d") + call pargi (blkfac) + } else + call printf (" blkfac=fixed") + + if (SCALE(fits) == YES) { + call printf (" bscale=%.7g bzero=%.7g\n") + call pargd (BSCALE(fits)) + call pargd (BZERO(fits)) + } else + call printf (" scaling=none\n") + call strupr (TYPE_STRING(fits)) + } + + # Write the cards to the FITS header. + repeat { + + # Encode the card. + stat = wft_card_encode (im, fits, card) + if (stat == NO) + next + + # Write the card to the output file if make_image is yes. + if (make_image == YES) + call wft_write_pixels (fits_fd, card, LEN_CARD) + + # Trim the card and write is to the standard output if + # long_header is yes. + + if (long_header == YES) { + call wft_trimstr (card, trim_card, LEN_CARD) + call printf ("%2d/%2d:-- %s\n") + call pargi (recntr) + call pargi (cardptr) + call pargstr (trim_card) + } + + if (mod (cardcnt, cards_per_rec) == 0) { + recntr = recntr + 1 + cardptr = 1 + } else + cardptr = cardptr + 1 + cardcnt = cardcnt + 1 + + } until (strncmp (card, "END ", LEN_KEYWORD) == 0) + + # Issue warning about possible precision loss. Comment this out + # for time being, since the short header was modified. + #if (SCALE(fits) == YES && bitpix != ERR) { + #call printf ( + #"\tDefault bitpix overridden: maximum precision loss ~%.7g\n") + #call pargd (BSCALE(fits)) + #} + + # Write the last header records. + if (make_image == YES) { + call wft_write_last_record (fits_fd, nrecords) + if (short_header == YES || long_header == YES) { + call printf ("\t%d Header ") + call pargi (nrecords) + } + } +end + + +# WFT_SET_BITPIX -- This procedure sets the FITS bitpix for each image based on +# either the user given value or the precision of the IRAF data. Notice that +# the user must explicitly set the bitpix parameter to -16 or -32 to select +# the IEEE output format. + +int procedure wft_set_bitpix (bitpix, datatype, data_bitpix) + +int bitpix # the user set bits per pixel, ERR or legal bitpix +int datatype # the IRAF image data type +int data_bitpix # the bits per pixel in the data + +begin + if (bitpix == ERR) { + switch (datatype) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + if (data_bitpix <= FITS_BYTE) + return (FITS_BYTE) + else if (data_bitpix <= FITS_SHORT) { + #if (datatype == TY_USHORT) + #return (FITS_LONG) + #else + return (FITS_SHORT) + } else + return (FITS_LONG) + case TY_REAL, TY_COMPLEX: + return (FITS_REAL) + case TY_DOUBLE: + return (FITS_DOUBLE) + default: + call error (2, "SET_BITPIX: Unknown IRAF data type.") + } + } else + return (bitpix) +end + + +# WFT_GET_IRAF_TYPESTRING -- Procedure to set the iraf datatype keyword. + +procedure wft_get_iraf_typestring (datatype, type_str) + +int datatype # the IRAF data type +char type_str[ARB] # the output IRAF type string + +begin + switch (datatype) { + case TY_SHORT: + call strcpy ("SHORT", type_str, LEN_STRING) + case TY_USHORT: + call strcpy ("USHORT", type_str, LEN_STRING) + case TY_INT: + call strcpy ("INTEGER", type_str, LEN_STRING) + case TY_LONG: + call strcpy ("LONG", type_str, LEN_STRING) + case TY_REAL: + call strcpy ("REAL", type_str, LEN_STRING) + case TY_DOUBLE: + call strcpy ("DOUBLE", type_str, LEN_STRING) + case TY_COMPLEX: + call strcpy ("COMPLEX", type_str, LEN_STRING) + default: + call error (3, "IRAF_TYPE: Unknown IRAF image type.") + } +end + + +# WFT_FITS_SET_SCALE -- Procedure to set the FITS scaling parameters if +# autoscaling is enabled. + +procedure wft_fits_set_scale (im, data_bitpix, fits_bitpix, irafmin, irafmax, + tapemin, tapemax, scale, bscale, bzero ) + +pointer im # pointer to IRAF image +int data_bitpix # bits per pixel of data +int fits_bitpix # fits bits per pixel +real irafmin # minimum picture value +real irafmax # maximum picture value +double tapemin # minimum tape value +double tapemax # maximum tape value +int scale # scale data ? +double bscale # FITS bscale +double bzero # FITS bzero + +errchk wft_set_scale + +begin + switch (PIXTYPE(im)) { + case TY_SHORT, TY_INT, TY_LONG: + if (data_bitpix > fits_bitpix) { + scale = YES + call wft_set_scale (fits_bitpix, irafmin, irafmax, tapemin, + tapemax, bscale, bzero) + } else { + scale = NO + bscale = 1.0d0 + bzero = 0.0d0 + } + case TY_USHORT: + if (data_bitpix > fits_bitpix) { + scale = YES + call wft_set_scale (fits_bitpix, irafmin, irafmax, tapemin, + tapemax, bscale, bzero) + } else if (data_bitpix == fits_bitpix) { + scale = YES + bscale = 1.0d0 + bzero = 3.2768d4 + } else { + scale = NO + bscale = 1.0d0 + bzero = 0.0d0 + } + case TY_REAL, TY_DOUBLE, TY_COMPLEX: + scale = YES + call wft_set_scale (fits_bitpix, irafmin, irafmax, tapemin, tapemax, + bscale, bzero) + default: + call error (1, "WRT_HEADER: Unknown IRAF image type.") + } + +end + + +# WFT_SET_SCALE -- This procedure calculates bscale and bzero for each frame +# from the FITS bitpix and the maximum and minimum data values. + +procedure wft_set_scale (fits_bitpix, datamin, datamax, mintape, maxtape, + bscale, bzero) + +int fits_bitpix # the FITS integer bits per pixels +real datamax, datamin # the IRAF image data minimum and maximum +double mintape, maxtape # min and max FITS tape values +double bscale, bzero # the calculated bscale and bzero values + +double maxdata, mindata, num, denom +bool rft_equald() + +begin + # Calculate the maximum and minimum values in the data. + maxdata = datamax #+ abs ((datamax / (10.0 ** (NDIGITS_RP - 1)))) + mindata = datamin #- abs ((datamin / (10.0 ** (NDIGITS_RP - 1)))) + num = maxdata - mindata + denom = (maxtape - mintape) * PREC_RATIO + + # Check for constant image case. + #mindata = datamin + #maxdata = datamax + if (rft_equald (num, 0.0d0)) { + bscale = 1.0d0 + bzero = maxdata + } else { + bscale = num / denom + #bzero = (maxtape / denom) * mindata - (mintape / denom) * maxdata + bzero = (maxdata + mindata) / 2.0d0 + } +end + + +# WFT_GET_TAPE_LIMITS -- Procedure for calculating the maximum and minimum FITS +# integer values from the FITS bitpix. + +procedure wft_get_tape_limits (fits_bitpix, mintape, maxtape) + +int fits_bitpix # the bits per pixel of a FITS integer +double maxtape, mintape # the maximun and minimum FITS tape integers + +begin + switch (fits_bitpix) { + case FITS_BYTE: + maxtape = BYTE_MAX + mintape = BYTE_MIN + case FITS_SHORT: + maxtape = SHORT_MAX + mintape = SHORT_MIN + case FITS_LONG: + maxtape = LONG_MAX + mintape = LONG_MIN + default: + call error (4, "TAPE_LIMITS: Unknown FITS type.") + } +end + + +# WFT_SET_BLANK -- Determine the FITS integer value for a blank pixel from the +# FITS bitpix. Notice that these are null ops for IEEE floating point format. + +procedure wft_set_blank (fits_bitpix, blank, blank_str) + +int fits_bitpix # the requested FITS bits per pixel +long blank # the FITS integer value of a blank pixel +char blank_str[ARB] # the encoded FITS integer value of a blank pixel + +begin + switch (fits_bitpix) { + case FITS_BYTE: + blank = long (BYTE_BLANK) + call strcpy ("0", blank_str, LEN_BLANK) + case FITS_SHORT: + blank = long (SHORT_BLANK) + call strcpy ("-32768", blank_str, LEN_BLANK) + case FITS_LONG: + blank = long (LONG_BLANK) + call strcpy ("-2147483648", blank_str, LEN_BLANK) + case FITS_REAL: + blank = INDEFL + call strcpy ("", blank_str, LEN_BLANK) + case FITS_DOUBLE: + blank = INDEFL + call strcpy ("", blank_str, LEN_BLANK) + default: + call error (5, "SET_BLANK: Unknown FITS type.") + } +end + + +# WFT_INIT_CARD_ENCODE -- This procedure initializes the card encoding +# procedure. The cards counters are initialized and the number of history cards +# calculated. + +int procedure wft_init_card_encode (im, fits) + +# both entry points +pointer im # pointer to the IRAF image +pointer fits # pointer to the WFITS structure + +# entry wft_card_encode +int wft_card_encode # entry point +char card[LEN_CARD+1] # string containing the card image + +int cardno, axisno, optiono, hist_ptr, unknown_ptr +int nstandard, noptions, stat +int wft_standard_card(), wft_option_card(), wft_last_card() +int wft_history_card(), wft_unknown_card() +errchk wft_standard_card, wft_option_card, wft_history_card +errchk wft_unknown_card, wft_last_card + +begin + # Initialize the card pointers. + cardno = 1 + axisno = 1 + optiono = 1 + unknown_ptr = 1 + hist_ptr = 1 + + # Initilaize the card counters. + nstandard = 3 + NAXIS(im) + noptions = NOPTIONS + nstandard + + return (YES) + + +# WFT_CARD_ENCODE -- Procedure to encode the FITS header parameters into +# FITS card images. + +entry wft_card_encode (im, fits, card) + + # Fetch the appropriate FITS header card image. + if (cardno <= nstandard) { + stat = wft_standard_card (cardno, im, fits, axisno, card) + } else if (cardno <= noptions) { + stat = wft_option_card (im, fits, optiono, card) + } else if (wft_unknown_card (im, unknown_ptr, card) == YES) { + stat = YES + } else if (wft_history_card (im, hist_ptr, card) == YES) { + stat = YES + } else { + stat = wft_last_card (card) + } + + cardno = cardno + 1 + + return (stat) +end + + +# WFT_TRIMSTR -- Procedure to trim trailing blanks from a fixed size string. + +procedure wft_trimstr (instr, outstr, nchars) + +char instr[ARB] # input string +char outstr[ARB] # output string +int nchars # last character of instr + +int ip + +begin + call strcpy (instr, outstr, nchars) + ip = nchars + while (outstr[ip] == ' ') + ip = ip - 1 + outstr[ip+1] = EOS +end diff --git a/pkg/dataio/fits/fits_wimage.x b/pkg/dataio/fits/fits_wimage.x new file mode 100644 index 00000000..7ed00372 --- /dev/null +++ b/pkg/dataio/fits/fits_wimage.x @@ -0,0 +1,497 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "wfits.h" + +# WFT_WRITE_IMAGE -- Procedure to convert IRAF image data to FITS format line by +# line. + +procedure wft_write_image (im, fits, fits_fd) + +pointer im # IRAF image descriptor +pointer fits # FITS data structure +int fits_fd # FITS file descriptor + +int npix, nlines, npix_record, i, stat, nrecords +long v[IM_MAXDIM] +pointer tempbuf, buf + +int wft_get_image_line() +errchk malloc, mfree, wft_get_image_line, wft_lscale_line, wft_long_line +errchk wft_init_write_pixels, wft_write_pixels, wft_write_last_record +errchk wft_rscale_line, wft_dscale_line + +include "wfits.com" + +begin + if (NAXIS(im) == 0) { + if (short_header == YES || long_header == YES) { + call printf ("0 Data logical (2880 byte) records written\n") + } + return + } + + # Initialize. + npix = NAXISN(im,1) + nlines = 1 + do i = 2, NAXIS(im) + nlines = nlines * NAXISN(im, i) + npix_record = len_record * FITS_BYTE / abs (FITS_BITPIX(fits)) + + call amovkl (long(1), v, IM_MAXDIM) + switch (FITS_BITPIX(fits)) { + case FITS_REAL: + + # Allocate temporary space. + call malloc (tempbuf, npix, TY_REAL) + + # Initialize the pixel write. + call wft_init_write_pixels (npix_record, TY_REAL, + FITS_BITPIX(fits), blkfac) + + # For the time being explicitly turn off ieee NaN mapping. + call ieemapr (NO, NO) + + # Scale the lines, deal with the blanks via the ieee code which + # is currently turned off, and write the output records. + + do i = 1, nlines { + iferr (stat = wft_get_image_line (im, buf, v, PIXTYPE(im))) { + call erract (EA_WARN) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + } + if (stat == EOF ) + return + if (stat != npix) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + if (SCALE(fits) == YES) + call wft_rscale_line (buf, Memr[tempbuf], npix, + 1. / BSCALE(fits), -BZERO(fits), PIXTYPE(im)) + else + call wft_real_line (buf, Memr[tempbuf], npix, PIXTYPE(im)) + call wft_write_pixels (fits_fd, Memr[tempbuf], npix) + } + + # Free space. + call mfree (tempbuf, TY_REAL) + + case FITS_DOUBLE: + + # Allocate temporary space. + call malloc (tempbuf, npix, TY_DOUBLE) + + # Initialize the pixel write. + call wft_init_write_pixels (npix_record, TY_DOUBLE, + FITS_BITPIX(fits), blkfac) + + # For the time being explicitly turn off ieee NaN mapping. + call ieemapd (NO, NO) + + # Scale the lines, deal with the blanks via the ieee code which + # is currently turned off, and write the output records. + + do i = 1, nlines { + iferr (stat = wft_get_image_line (im, buf, v, PIXTYPE(im))) { + call erract (EA_WARN) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + } + if (stat == EOF ) + return + if (stat != npix) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + if (SCALE(fits) == YES) + call wft_dscale_line (buf, Memd[tempbuf], npix, + 1. / BSCALE(fits), -BZERO(fits), PIXTYPE(im)) + else + call wft_double_line (buf, Memd[tempbuf], npix, + PIXTYPE(im)) + call wft_write_pixels (fits_fd, Memd[tempbuf], npix) + } + + # Free space. + call mfree (tempbuf, TY_DOUBLE) + + default: + + # Allocate temporary space. + call malloc (tempbuf, npix, TY_LONG) + + # Scale the line, deal with the blanks, and write the output + # record. At the moement blanks are not dealt with. + + call wft_init_write_pixels (npix_record, TY_LONG, FITS_BITPIX(fits), + blkfac) + do i = 1, nlines { + iferr (stat = wft_get_image_line (im, buf, v, PIXTYPE(im))) { + call erract (EA_WARN) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + } + if (stat == EOF ) + return + if (stat != npix) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + if (SCALE(fits) == YES) + call wft_lscale_line (buf, Meml[tempbuf], npix, + 1. / BSCALE(fits), -BZERO(fits), PIXTYPE(im)) + else + call wft_long_line (buf, Meml[tempbuf], npix, PIXTYPE(im)) + # call map_blanks (im, Meml[tempbuf], blank) + call wft_write_pixels (fits_fd, Meml[tempbuf], npix) + } + # Free space. + call mfree (tempbuf, TY_LONG) + } + + # Write the final record. + call wft_write_last_record (fits_fd, nrecords) + if (short_header == YES || long_header == YES) { + call printf ("%d Data logical (2880 byte) records written\n") + call pargi (nrecords) + } +end + + +# WFT_GET_IMAGE_LINE -- Procedure to fetch the next image line. + +int procedure wft_get_image_line (im, buf, v, datatype) + +pointer im # IRAF image descriptor +pointer buf # pointer to image line +long v[ARB] # imio dimension descriptor +int datatype # IRAF image data type + +int npix +int imgnll(), imgnlr(), imgnld(), imgnlx() +errchk imgnll, imgnlr, imgnld, imgnlx + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + npix = imgnll (im, buf, v) + case TY_REAL: + npix = imgnlr (im, buf, v) + case TY_DOUBLE: + npix = imgnld (im, buf, v) + case TY_COMPLEX: + npix = imgnlx (im, buf, v) + default: + call error (11, "GET_IMAGE_LINE: Unknown IRAF image type.") + } + + return (npix) +end + + +# WFT_RSCALE_LINE -- This procedure converts the IRAF data to type real +# and scales by the FITS parameters bscale and bzero. + +procedure wft_rscale_line (buf, outbuffer, npix, bscale, bzero, datatype) + +pointer buf # pointer to IRAF image line +real outbuffer[ARB] # FITS integer buffer +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero parameters +int datatype # data type of image + +errchk achtlr, altadr, amovr, achtdr, acthxr + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call achtlr (Meml[buf], outbuffer, npix) + call altadr (outbuffer, outbuffer, npix, bzero, bscale) + case TY_REAL: + call amovr (Memr[buf], outbuffer, npix) + call altadr (outbuffer, outbuffer, npix, bzero, bscale) + case TY_DOUBLE: + call achtdr (Memd[buf], outbuffer, npix) + call altadr (outbuffer, outbuffer, npix, bzero, bscale) + case TY_COMPLEX: + call achtxr (Memx[buf], outbuffer, npix) + call altadr (outbuffer, outbuffer, npix, bzero, bscale) + default: + call error (12, "WFT_RSCALE_LINE: Unknown IRAF image type.") + } +end + + +# WFT_DSCALE_LINE -- This procedure converts the IRAF data to type double with +# after scaling by the FITS parameters bscale and bzero. + +procedure wft_dscale_line (buf, outbuffer, npix, bscale, bzero, datatype) + +pointer buf # pointer to IRAF image line +double outbuffer[ARB] # FITS integer buffer +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero parameters +int datatype # data type of image + +errchk achtld, altad, amovd, achtrd, achtxd + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call achtld (Meml[buf], outbuffer, npix) + call altad (outbuffer, outbuffer, npix, bzero, bscale) + case TY_REAL: + call achtrd (Memr[buf], outbuffer, npix) + call altad (outbuffer, outbuffer, npix, bzero, bscale) + case TY_DOUBLE: + call amovd (Memd[buf], outbuffer, npix) + call altad (outbuffer, outbuffer, npix, bzero, bscale) + case TY_COMPLEX: + call achtxd (Memx[buf], outbuffer, npix) + call altad (outbuffer, outbuffer, npix, bzero, bscale) + default: + call error (12, "WFT_DSCALE_LINE: Unknown IRAF image type.") + } +end + + +# WFT_LSCALE_LINE -- This procedure converts the IRAF data to type long with +# after scaling by the FITS parameters bscale and bzero. + +procedure wft_lscale_line (buf, outbuffer, npix, bscale, bzero, datatype) + +pointer buf # pointer to IRAF image line +long outbuffer[ARB] # FITS integer buffer +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero parameters +int datatype # data type of image + +errchk altall, altarl, altadl, altaxl + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call altall (Meml[buf], outbuffer, npix, bzero, bscale) + case TY_REAL: + call altarl (Memr[buf], outbuffer, npix, bzero, bscale) + case TY_DOUBLE: + call altadl (Memd[buf], outbuffer, npix, bzero, bscale) + case TY_COMPLEX: + call altaxl (Memx[buf], outbuffer, npix, bzero, bscale) + default: + call error (12, "WFT_LSCALE_LINE: Unknown IRAF image type.") + } +end + + +# WFT_REAL_LINE -- This procedure converts the IRAF image line to type long with +# no scaling. + +procedure wft_real_line (buf, outbuffer, npix, datatype) + +pointer buf # pointer to IRAF image line +real outbuffer[ARB] # buffer of FITS integers +int npix # number of pixels +int datatype # IRAF image datatype + +errchk achtlr, achtdr, amovr, achtxr + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call achtlr (Meml[buf], outbuffer, npix) + case TY_REAL: + call amovr (Memr[buf], outbuffer, npix) + case TY_DOUBLE: + call achtdr (Memd[buf], outbuffer, npix) + case TY_COMPLEX: + call achtxr (Memx[buf], outbuffer, npix) + default: + call error (13, "WFT_REAL_LINE: Unknown IRAF data type.") + } +end + + +# WFT_DOUBLE_LINE -- This procedure converts the IRAF image line to type long +# with no scaling. + +procedure wft_double_line (buf, outbuffer, npix, datatype) + +pointer buf # pointer to IRAF image line +double outbuffer[ARB] # buffer of FITS integers +int npix # number of pixels +int datatype # IRAF image datatype + +errchk achtld, achtrd, amovd, achtxd + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call achtld (Meml[buf], outbuffer, npix) + case TY_REAL: + call achtrd (Memr[buf], outbuffer, npix) + case TY_DOUBLE: + call amovd (Memd[buf], outbuffer, npix) + case TY_COMPLEX: + call achtxd (Memx[buf], outbuffer, npix) + default: + call error (13, "WFT_DOUBLE_LINE: Unknown IRAF data type.") + } +end + + +# WFT_LONG_LINE -- This procedure converts the IRAF image line to type long with +# no scaling. + +procedure wft_long_line (buf, outbuffer, npix, datatype) + +pointer buf # pointer to IRAF image line +long outbuffer[ARB] # buffer of FITS integers +int npix # number of pixels +int datatype # IRAF image datatype + +errchk amovl, achtrl, achtdl, achtxl + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call amovl (Meml[buf], outbuffer, npix) + case TY_REAL: + call achtrl (Memr[buf], outbuffer, npix) + case TY_DOUBLE: + call achtdl (Memd[buf], outbuffer, npix) + case TY_COMPLEX: + call achtxl (Memx[buf], outbuffer, npix) + default: + call error (13, "WFT_LONG_LINE: Unknown IRAF data type.") + } +end + + +# ALTALL -- Procedure to linearly scale a long vector into a long vector +# using double precision constants to preserve precision. + +procedure altall (a, b, npix, k1, k2) + +long a[ARB] # input vector +long b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +double dtemp +int i + +begin + do i = 1, npix { + dtemp = (a[i] + k1) * k2 + if (dtemp >= 0.0d0) + dtemp = dtemp + 0.5d0 + else + dtemp = dtemp - 0.5d0 + b[i] = dtemp + } +end + + +# ALTARL -- Procedure to linearly scale a real vector into a long vector +# using double precision constants to preserve precision. + +procedure altarl (a, b, npix, k1, k2) + +real a[ARB] # input vector +long b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +int i +double dtemp + +begin + do i = 1, npix { + dtemp = (a[i] + k1) * k2 + if (dtemp >= 0.0d0) + dtemp = dtemp + 0.5d0 + else + dtemp = dtemp - 0.5d0 + b[i] = dtemp + } +end + + +# ALTADL -- Procedure to linearly scale a double vector into a long vector +# using double precision constants to preserve precision. + +procedure altadl (a, b, npix, k1, k2) + +double a[ARB] # input vector +long b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +int i +double dtemp + +begin + do i = 1, npix { + dtemp = (a[i] + k1) * k2 + if (dtemp >= 0.0d0) + dtemp = dtemp + 0.5d0 + else + dtemp = dtemp - 0.5d0 + b[i] = dtemp + } +end + + +# ALTAXL -- Procedure to linearly scale a complex vector into a long vector +# using double precision constants to preserve precision. + +procedure altaxl (a, b, npix, k1, k2) + +complex a[ARB] # input vector +long b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +int i +double dtemp + +begin + do i = 1, npix { + dtemp = (a[i] + k1) * k2 + if (dtemp >= 0.0d0) + dtemp = dtemp + 0.5d0 + else + dtemp = dtemp - 0.5d0 + b[i] = dtemp + } +end + + +# ALTADR -- Procedure to linearly scale a real vector in double precision + +procedure altadr (a, b, npix, k1, k2) + +real a[ARB] # input vector +real b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +int i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end + + +# ALTADX -- Procedure to linearly scale a complex vector in double precision + +procedure altadx (a, b, npix, k1, k2) + +complex a[ARB] # input vector +complex b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +int i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end + diff --git a/pkg/dataio/fits/fits_wpixels.x b/pkg/dataio/fits/fits_wpixels.x new file mode 100644 index 00000000..7a9389ac --- /dev/null +++ b/pkg/dataio/fits/fits_wpixels.x @@ -0,0 +1,162 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "wfits.h" + +# WFT_INIT_WRITE_PIXELS -- This procedure calculates the input and +# output buffer sizes based in the spp and mii data types and allocates +# the required space. + +procedure wft_init_write_pixels (npix_record, spp_type, bitpix, blkfac) + +int npix_record # number of data pixels per record +int spp_type # pixel data type +int bitpix # output bits per pixel +int blkfac # fits blocking factor (0 for disk) + +# entry wft_write_pixels, wft_write_last_record + +int fd # output file descriptor +char buffer[1] # input buffer +int npix # number of pixels in the input buffer +int nrecords # number of FITS records written + +char blank, zero +int ty_mii, ty_spp, npix_rec, nch_rec, len_mii, sz_rec, nchars, n, nrec +int bf, szblk +pointer spp, mii, ip, op + +int sizeof(), miilen(), fstati() +long note() +errchk malloc, mfree, write, miipak, amovc +data mii /NULL/, spp/NULL/ + +begin + # Change input parameters into local variables. + ty_mii = bitpix + ty_spp = spp_type + npix_rec = npix_record + nch_rec = npix_rec * sizeof (ty_spp) + bf = blkfac + blank = ' ' + zero = 0 + + # Compute the size of the mii buffer. + len_mii = miilen (npix_rec, ty_mii) + sz_rec = len_mii * SZ_INT32 + + # Allocate space for the buffers. + if (spp != NULL) + call mfree (spp, TY_CHAR) + call malloc (spp, nch_rec, TY_CHAR) + if (mii != NULL) + call mfree (mii, TY_INT) + call malloc (mii, len_mii, TY_INT) + + op = 0 + nrec = 0 + + return + +# WFT_WRITE_PIXELS -- Wft_wrt_pixels gets an image line and places it in the +# output buffer. When the output buffer is full the data are packed by the mii +# routines and written to the specified output. + +entry wft_write_pixels (fd, buffer, npix) + + nchars = npix * sizeof (ty_spp) + ip = 0 + + repeat { + + # Fill output buffer. + n = min (nch_rec - op, nchars - ip) + call amovc (buffer[1 + ip], Memc[spp + op], n) + ip = ip + n + op = op + n + + # Write output record. + if (op == nch_rec) { + call miipak (Memc[spp], Memi[mii], npix_rec, ty_spp, ty_mii) + iferr (call write (fd, Memi[mii], sz_rec)) { + if (ty_spp == TY_CHAR) { + call printf (" File incomplete: %d logical header") + call pargi (nrec) + call printf (" (2880 byte) records written\n") + call error (18, + "WRT_RECORD: Error writing header record.") + } else { + call printf (" File incomplete: %d logical data") + call pargi (nrec) + call printf (" (2880 byte) records written\n") + call error (19, + "WRT_RECORD: Error writing data record.") + } + } + + nrec = nrec + 1 + op = 0 + } + + } until (ip == nchars) + + return + + +# WFT_WRITE_LAST_RECORD -- Procedure to write the last partially filled record +# to tape. Fill with blanks if header record otherwise fill with zeros. + +entry wft_write_last_record (fd, nrecords) + + if (op != 0) { + + # Blank or zero fill the last record. + n = nch_rec - op + if (ty_spp == TY_CHAR) + call amovkc (blank, Memc[spp + op], n) + else + call amovkc (zero, Memc[spp + op], n) + + # Write last record. + call miipak (Memc[spp], Memi[mii], npix_rec, ty_spp, ty_mii) + iferr (call write (fd, Memi[mii], sz_rec)) { + if (ty_spp == TY_CHAR) { + call printf ("File incomplete: %d logical header") + call pargi (nrec) + call printf (" (2880 byte) records written\n") + call error (18, + "WRT_LAST_RECORD: Error writing last header record.") + } else { + call printf ("File incomplete: %d logical data") + call pargi (nrec) + call printf (" (2880 byte) records written\n") + call error (19, + "WRT_LAST_RECORD: Error writing last data record.") + } + } + + + nrec = nrec + 1 + + # Pad out the record if the blocking is non-standard. + szblk = fstati (fd, F_BUFSIZE) * SZB_CHAR + if ((bf > 0) && mod (szblk, FITS_RECORD) != 0 && + (ty_spp != TY_CHAR)) { + szblk = szblk / SZB_CHAR + n = note (fd) - 1 + if (mod (n, szblk) == 0) + n = 0 + else + n = szblk - mod (n, szblk) + for (op = 1; op <= n; op = op + nch_rec) { + szblk = min (nch_rec, n - op + 1) + call amovkc (zero, Memc[spp], szblk) + #call write (fd, Memc[spp], szblk) + } + } + + } + + nrecords = nrec +end diff --git a/pkg/dataio/fits/fits_write.x b/pkg/dataio/fits/fits_write.x new file mode 100644 index 00000000..edfc9f83 --- /dev/null +++ b/pkg/dataio/fits/fits_write.x @@ -0,0 +1,246 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "wfits.h" + +# WFT_WRITE_FITZ -- Procedure to convert a single IRAF file to a FITS file. +# If the make_image switch is set the header and pixel files are output +# to the output destination. If the make_image switch is off the header +# is printed to the standard output. + +procedure wft_write_fitz (iraf_file, fits_file, image_number, nimages) + +char iraf_file[ARB] # IRAF file name +char fits_file[ARB] # FITS file name +int image_number # the current image number +int nimages # the number of images + +int fits_fd, chars_rec, nchars, ip, min_lenuserarea +pointer im, sp, fits, envstr + +int mtfile(), mtopen(), open(), fnldir(), envfind(), ctoi() +pointer immap() +errchk immap, imunmap, open, mtopen, close, smark, salloc, sfree +errchk delete, wft_write_header, wft_write_image, wft_data_limits + +include "wfits.com" + +begin + # Open the output file. Check whether the output file is a magtape + # device or a binary file. If the output file is magtape check + # for a legal blocking factor. + + if (image_number == 1 || wextensions == NO) { + if (make_image == NO) + call strcpy ("dev$null", fits_file, SZ_FNAME) + if (mtfile (fits_file) == YES) { + chars_rec = (blkfac * len_record * FITS_BYTE) / (SZB_CHAR * + NBITS_BYTE) + fits_fd = mtopen (fits_file, WRITE_ONLY, chars_rec) + } else + fits_fd = open (fits_file, NEW_FILE, BINARY_FILE) + } + + # Allocate memory for program data structure. + call smark (sp) + call salloc (fits, LEN_FITS, TY_STRUCT) + call salloc (envstr, SZ_FNAME, TY_CHAR) + + # Set up the minimum length of the user area. + if (envfind ("min_lenuserarea", Memc[envstr], SZ_FNAME) > 0) { + ip = 1 + if (ctoi (Memc[envstr], ip, min_lenuserarea) <= 0) + min_lenuserarea = LEN_USERAREA + else + min_lenuserarea = max (LEN_USERAREA, min_lenuserarea) + } else + min_lenuserarea = LEN_USERAREA + + # Write the global header. + if (image_number == 1 && gheader == YES) { + + XTENSION(fits) = EXT_PRIMARY + + # Open a dummy image. + im = immap ("dev$null", NEW_IMAGE, 0) + NAXIS(im) = 0 + PIXTYPE(im) = TY_SHORT + OBJECT(im) = EOS + IRAFNAME(fits) = EOS + + if (long_header == YES || short_header == YES) { + call printf ("Global header") + if (make_image == YES) { + call printf (" -> %s[0] ") + call pargstr (fits_file) + } + if (long_header == YES) + call printf ("\n") + else if (short_header == YES) + call printf (" ") + } + call flush (STDOUT) + + iferr { + call wft_write_header (im, fits, fits_fd) + if (make_image == YES) + call wft_write_image (im, fits, fits_fd) + } then { + + # Print the error message. + call flush (STDOUT) + call erract (EA_WARN) + + # Close files and cleanup. + call imunmap (im) + #if (image_number == nimages || wextensions == NO) + call close (fits_fd) + if (make_image == NO) + call delete (fits_file) + call sfree (sp) + + # Assert an error. + call erract (EA_ERROR) + + } else { + call imunmap (im) + } + + if (long_header == YES) + call printf ("\n") + } + + # Map the input image. Construct the old iraf name by removing + # the directory specification. + # Print the id string. + if (long_header == YES || short_header == YES) { + call printf ("Image %d: %s") + call pargi (image_number) + call pargstr (iraf_file) + } + + # Define whether the image to be written is to be the FITS primary + # data image file or a FITS image extension file. + if (image_number == 1) { + if (wextensions == YES && gheader == YES) + XTENSION(fits) = EXT_IMAGE + else + XTENSION(fits) = EXT_PRIMARY + } else { + if (wextensions == YES) + XTENSION(fits) = EXT_IMAGE + else + XTENSION(fits) = EXT_PRIMARY + } + + im = immap (iraf_file, READ_ONLY, min_lenuserarea) + call imgcluster (iraf_file, IRAFNAME(fits), SZ_FNAME) + nchars = fnldir (IRAFNAME(fits), IRAFNAME(fits), SZ_FNAME) + call strcpy (iraf_file[nchars+1], IRAFNAME(fits), SZ_FNAME) + + # Write header and image. + iferr { + + if (short_header == YES || long_header == YES) { + if (make_image == YES) { + if (wextensions == YES && nimages > 1) { + call printf (" -> %s[%d] ") + call pargstr (fits_file) + if (gheader == YES) + call pargi (image_number) + else + call pargi (image_number - 1) + } else { + call printf (" -> %s ") + call pargstr (fits_file) + } + } + if (long_header == YES) + call printf ("\n") + else if (short_header == YES) + call printf (" ") + } + call flush (STDOUT) + + call wft_write_header (im, fits, fits_fd) + if (make_image == YES) + call wft_write_image (im, fits, fits_fd) + + if (long_header == YES) + call printf ("\n") + + } then { + + # Print the error message. + call flush (STDOUT) + call erract (EA_WARN) + + # Close files and cleanup. + call imunmap (im) + #if (image_number == nimages || wextensions == NO) + call close (fits_fd) + if (make_image == NO) + call delete (fits_file) + call sfree (sp) + + # Assert an error. + call erract (EA_ERROR) + + } else { + + # Close files and cleanup. + call imunmap (im) + if (image_number == nimages || wextensions == NO) + call close (fits_fd) + if (make_image == NO) + call delete (fits_file) + call sfree (sp) + } + +end + + +# WFT_DATA_LIMITS -- Procedure to calculate the maximum and minimum data values +# in an IRAF image. Values are only calculated if the max and min are unknown +# or the image has been modified since the last values were calculated. + +procedure wft_data_limits (im, irafmin, irafmax) + +pointer im # image pointer +real irafmin # minimum picture value +real irafmax # maximum picture value + +int npix +long v[IM_MAXDIM] +pointer buf +real maxval, minval +int imgnlr() +errchk imgnlr + +begin + # Compute the data minimum and maximum if the image values + # are undefined out-of-date. + + if (LIMTIME(im) < MTIME(im) && NAXIS(im) > 0) { + + irafmax = -MAX_REAL + irafmin = MAX_REAL + npix = NAXISN(im,1) + + call amovkl (long(1), v, IM_MAXDIM) + while (imgnlr (im, buf, v) != EOF) { + call alimr (Memr[buf], npix, minval, maxval) + irafmin = min (irafmin, minval) + irafmax = max (irafmax, maxval) + } + + } else { + + irafmax = IM_MAX(im) + irafmin = IM_MIN(im) + + } +end diff --git a/pkg/dataio/fits/mkpkg b/pkg/dataio/fits/mkpkg new file mode 100644 index 00000000..ac5201d0 --- /dev/null +++ b/pkg/dataio/fits/mkpkg @@ -0,0 +1,24 @@ +# Make the RFITS / WFITS Tasks + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + fits_cards.x wfits.com wfits.h + fits_params.x wfits.h + fits_read.x rfits.com rfits.h \ + + fits_rheader.x rfits.com rfits.h \ + + fits_rimage.x rfits.com rfits.h + fits_rpixels.x + fits_wheader.x wfits.com wfits.h + fits_wimage.x wfits.com wfits.h + fits_wpixels.x wfits.h + fits_write.x wfits.com wfits.h + fits_files.x + t_rfits.x rfits.com rfits.h + t_wfits.x wfits.com wfits.h + ; diff --git a/pkg/dataio/fits/rfits.com b/pkg/dataio/fits/rfits.com new file mode 100644 index 00000000..08f44c0e --- /dev/null +++ b/pkg/dataio/fits/rfits.com @@ -0,0 +1,18 @@ + +# FITS reader common + +int len_record # Length of FITS records in bytes +int data_type # Output data type +real blank # Blank value +real fe # Maximum size in megabytes for scan mode + +# Option flags + +int make_image # Create an IRAF image +int long_header # Print a long header (FITS header cards) +int short_header # Print a short header (Title and size) +int scale # Scale the data +int old_name # Use old IRAF name? + +common /rfitscom/ len_record, data_type, blank, fe, make_image, long_header, + short_header, scale, old_name diff --git a/pkg/dataio/fits/rfits.h b/pkg/dataio/fits/rfits.h new file mode 100644 index 00000000..bab29220 --- /dev/null +++ b/pkg/dataio/fits/rfits.h @@ -0,0 +1,96 @@ +# FITS Definitions + +# The FITS standard readable by the FITS reader using these definitions: +# +# 1. 8 bits / byte +# 2. ASCII character code +# 3. MII integer data format (i.e. 8 bit unsigned integers and 16 and 32 +# bit signed twos complement integers with most significant bytes first.) +# 4. IEEE 32 and 64 bit floating point format +# +# +# The following deviations from the FITS standard are allowed: +# +# 1. The number of FITS bytes per record is normally 2880 or up to 10 times +# 2880 bytes but may be arbitrarily specified by the user. + +# Define the bits per pixel, precision and byte order of the basic FITS types + +define FITS_RECORD 2880 # number of bytes in a standard FITS record + +define FITS_BYTE 8 # Bits in a FITS byte +define FITS_SHORT 16 # Bits in a FITS short +define FITS_LONG 32 # Bits in a FITS long +define FITS_REAL -32 # Bits in a FITS real * -1 +define FITS_DOUBLE -64 # Bits in a FITS double * -1 + +define FITSB_PREC 3 # Decimal digits of precision in a FITS byte +define FITSS_PREC 5 # Decimal digits of precision in a FITS short +define FITSL_PREC 10 # Decimal digits of precision in a FITS long + +define LSBF NO # Least significant byte first + +# Define the basic format of a FITS cardimage + +define LEN_CARD 80 # Length of FITS card in characters +define COL_VALUE 11 # Starting column for parameter values + + +# FITS standards not recognized currently by IRAF. +# +# 1. SIMPLE SIMPLE = 'F' not implemented, file skipped +# 2. GROUPS Group data not currently implemented, file skippped + +# FITS extension currently recognised by IRAF + +define EXT_PRIMARY 1 # recognized and read +define EXT_IMAGE 2 # recognized and read +define EXT_TABLE 3 # recognized and skipped +define EXT_BINTABLE 4 # recognized and skipped +define EXT_UNKNOWN 5 # unrecognized and skipped +define EXT_SPECIAL 6 # undefined + + +# Values for the following quantities are stored in the structure below. + +define LEN_FITS (20 + SZ_FNAME + 1) + +define FITS_BSCALE Memd[P2D($1)] # FITS scaling parameter +define FITS_BZERO Memd[P2D($1+2)] # FITS zero parameter +define BLANK_VALUE Meml[P2L($1+4)] # Blank value +define BLANKS Memi[$1+5] # YES if blank keyword in header +define BITPIX Memi[$1+6] # Bits per pixel (Must be an MII type) +define SCALE Memi[$1+7] # Scale the data ? +define SIMPLE Memi[$1+8] # Standard FITS format +define NRECORDS Memi[$1+9] # Number of FITS logical records +define EXTEND Memi[$1+10] # FITS extensions may be present +define XTENSION Memi[$1+11] # FITS extension type +define PCOUNT Memi[$1+12] # Number of random parameters +define GCOUNT Memi[$1+13] # Number of groups +define GLOBALHDR Memi[$1+14] # Global header may be present +define INHERIT Memi[$1+15] # Inherit global header if present +define IRAFNAME Memc[P2C($1+16)] # Old IRAF name + +# Mapping of additional IRAF header parameters + +define PIXTYPE IM_PIXTYPE($1) +define NBPIX IM_NBPIX($1) +define IRAFMAX IM_MAX($1) +define IRAFMIN IM_MIN($1) +define LIMTIME IM_LIMTIME($1) +define LEN_USERAREA 28800 + +# Mapping of FITS Keywords to IRAF image header + +define NAXIS IM_NDIM($1) +define NAXISN IM_LEN($1,$2) +define OBJECT IM_TITLE($1) +define HISTORY IM_HISTORY($1) +define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] # All unrecognized keywords + # are stored here +# Miscellaneous definitions. + +define SZ_OBJECT SZ_IMTITLE +define SZ_HISTORY SZ_IMHIST +define SZ_FCTYPE SZ_CTYPE +define LEN_TYPESTR 8 diff --git a/pkg/dataio/fits/t_rfits.x b/pkg/dataio/fits/t_rfits.x new file mode 100644 index 00000000..06c55ec1 --- /dev/null +++ b/pkg/dataio/fits/t_rfits.x @@ -0,0 +1,216 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "rfits.h" + +define NTYPES 7 # the number of image data types + +# RFITS -- Read FITS format data. Further documentation given in rfits.hlp + +procedure t_rfits() + +int inlist, outlist, len_inlist, len_outlist +int file_number, offset, stat, first_file, last_file +pointer sp, infile, file_list, outfile, ext_list, in_fname, out_fname +pointer pl, axes + +bool clgetb(), pl_linenotempty() +#char clgetc() +int rft_get_image_type(), clgeti(), mtfile(), strlen(), btoi(), fntlenb() +int rft_read_fitz(), fntgfnb(), fstati(), mtneedfileno(), fntrfnb() +pointer fntopnb(), rft_flist() +real clgetr(), rft_fe() + +include "rfits.com" + +begin + # Set up the standard output to flush on a newline. + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (file_list, SZ_LINE, TY_CHAR) + call salloc (outfile, SZ_FNAME, TY_CHAR) + call salloc (ext_list, SZ_LINE, TY_CHAR) + call salloc (in_fname, SZ_FNAME, TY_CHAR) + call salloc (out_fname, SZ_FNAME, TY_CHAR) + call salloc (axes, 2, TY_INT) + + # Get RFITS parameters. + call clgstr ("fits_file", Memc[infile], SZ_FNAME) + long_header = btoi (clgetb ("long_header")) + short_header = btoi (clgetb ("short_header")) + len_record = FITS_RECORD + old_name = btoi (clgetb ("oldirafname")) + make_image = btoi (clgetb ("make_image")) + + # Open the input file list. + call clgstr ("file_list", Memc[ext_list], SZ_LINE) + if (mtfile (Memc[infile]) == YES) { + inlist = NULL + if (mtneedfileno (Memc[infile]) == YES) { + call strcpy (Memc[ext_list], Memc[file_list], SZ_LINE) + } else { + call sprintf (Memc[file_list], SZ_LINE, "1[%s]") + call pargstr (Memc[ext_list]) + } + } else { + inlist = fntopnb (Memc[infile], NO) + len_inlist = fntlenb (inlist) + if (len_inlist > 0) { + if (Memc[ext_list] == EOS) { + call sprintf (Memc[file_list], SZ_LINE, "1-%d[0]") + call pargi (len_inlist) + #call pargstr (Memc[ext_list]) + } else { + call sprintf (Memc[file_list], SZ_LINE, "1-%d[%s]") + call pargi (len_inlist) + call pargstr (Memc[ext_list]) + } + } else { + call sprintf (Memc[file_list], SZ_LINE, "0[%s]") + call pargstr (Memc[ext_list]) + } + } + + # Decode the ranges string. + pl = rft_flist (Memc[file_list], first_file, last_file, len_inlist) + if (pl == NULL || len_inlist <= 0) + call error (1, "T_RFITS: Illegal file/extensions number list") + + # Open the output file list. + if (make_image == YES) { + call clgstr ("iraf_file", Memc[outfile], SZ_FNAME) + if (Memc[outfile] == EOS) { + if (old_name == YES) + call mktemp ("tmp$", Memc[outfile], SZ_FNAME) + else + call error (0, "T_RFITS: Undefined output file name") + } + outlist = fntopnb (Memc[outfile], NO) + len_outlist = fntlenb (outlist) + offset = clgeti ("offset") + } else { + Memc[outfile] = EOS + outlist = NULL + len_outlist = 1 + } + if ((len_outlist > 1) && (len_outlist != len_inlist)) + call error (0, + "T_RFITS: Output and input lists have different lengths") + + # Get the remaining parameters. Use the string in_fname as a + # temporary variable. + #data_type = rft_get_image_type (clgetc ("datatype")) + call clgstr ("datatype", Memc[in_fname], SZ_FNAME) + data_type = rft_get_image_type (Memc[in_fname]) + scale = btoi (clgetb ("scale")) + blank = clgetr ("blank") + + # Get the scan size parameter. + fe = rft_fe (Memc[infile]) + + # Read successive FITS files, convert and write into a numbered + # succession of output IRAF files. + + do file_number = first_file, last_file { + + # Get the next file number. + Memi[axes] = 1 + Memi[axes+1] = file_number + if (! pl_linenotempty (pl, Memi[axes])) + next + + # Get the input file name. + if (inlist != NULL) { + if (fntgfnb (inlist, Memc[in_fname], SZ_FNAME) == EOF) + call error (0, "T_RFITS: Error reading input file name") + } else { + if (mtneedfileno (Memc[infile]) == YES) + call mtfname (Memc[infile], file_number, Memc[in_fname], + SZ_FNAME) + else + call strcpy (Memc[infile], Memc[in_fname], SZ_FNAME) + } + + # Get the output file name. + if (outlist == NULL) { + Memc[out_fname] = EOS + } else if (len_inlist > len_outlist) { + if (fntrfnb (outlist, 1, Memc[out_fname], SZ_FNAME) == EOF) + call strcpy (Memc[outfile], Memc[out_fname], SZ_FNAME) + if (len_inlist > 1) { + call sprintf (Memc[out_fname+strlen(Memc[out_fname])], + SZ_FNAME, "%04d") + call pargi (file_number + offset) + } + } else if (fntgfnb (outlist, Memc[out_fname], SZ_FNAME) == EOF) + call error (0, "T_RFITS: Error reading output file name") + + # Convert FITS file to the output IRAF file. If EOT is reached + # then exit. If an error is detected then print a warning and + # continue with the next file. + + iferr (stat = rft_read_fitz (Memc[in_fname], Memc[out_fname], + pl, file_number)) + call erract (EA_FATAL) + if (stat == EOF) + break + } + + if (inlist != NULL) + call fntclsb (inlist) + if (outlist != NULL) + call fntclsb (outlist) + if (pl != NULL) + call pl_close (pl) + + call sfree (sp) +end + + +# RFT_GET_IMAGE_TYPE -- Convert a character to and IRAF image type. + +int procedure rft_get_image_type (c) + +char c + +int type_codes[NTYPES], i +string types "usilrdx" +int stridx() +data type_codes /TY_USHORT, TY_SHORT, TY_INT, TY_LONG, TY_REAL, + TY_DOUBLE, TY_COMPLEX/ +begin + i = stridx (c, types) + if (i == 0) + return (ERR) + else + return (type_codes[stridx(c,types)]) +end + + +# RFT_FE -- Fetch the maximum file size in MB for tape scanning mode. + +real procedure rft_fe (file) + +char file[ARB] # the input file name + +pointer gty +real fe +int mtfile(), gtygeti() +pointer mtcap() +errchk gtygeti() + +begin + if (mtfile (file) == NO) + return (0.0) + iferr (gty = mtcap (file)) + return (0.0) + iferr (fe = gtygeti (gty, "fe")) + fe = 0.0 + call gtyclose (gty) + return (fe) +end diff --git a/pkg/dataio/fits/t_wfits.x b/pkg/dataio/fits/t_wfits.x new file mode 100644 index 00000000..256b9cde --- /dev/null +++ b/pkg/dataio/fits/t_wfits.x @@ -0,0 +1,253 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "wfits.h" + +# T_WFITS -- This procedure converts a series of IRAF image files to +# FITS image files. + +procedure t_wfits () + +char iraf_files[SZ_FNAME] # list of IRAF images +char fits_files[SZ_FNAME] # list of FITS files +bool newtape # new or used tape ? +char in_fname[SZ_FNAME] # input file name +char out_fname[SZ_FNAME] # output file name +char fextn[SZ_FNAME] # the fits extension + +char ch +int imlist, flist, nimages, nfiles, file_number, addext, index +bool clgetb(), streq() +double clgetd() +int imtopen(), imtlen (), wft_get_bitpix(), clgeti(), imtgetim() +int mtfile(), btoi(), fstati(), fntlenb(), fntgfnb(), mtneedfileno() +int wft_blkfac(), fntrfnb(), strlen(), strldx() +pointer fntopnb() + +include "wfits.com" + +begin + # Flush on a newline if STDOUT has not been redirected. + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Open iraf_files template and determine number of files in list. + call clgstr ("iraf_files", iraf_files, SZ_FNAME) + imlist = imtopen (iraf_files) + nimages = imtlen (imlist) + + # Get the wfits parameters. + if (nimages == 1) + wextensions = NO + else + wextensions = btoi (clgetb ("extensions")) + if (wextensions == NO) + gheader = NO + else + gheader = btoi (clgetb ("global_hdr")) + long_header = btoi (clgetb ("long_header")) + short_header = btoi (clgetb ("short_header")) + make_image = btoi (clgetb ("make_image")) + + # Get the FITS bits per pixel and the FITS logical record size. + bitpix = wft_get_bitpix (clgeti ("bitpix")) + len_record = FITS_RECORD + + # Get the scaling parameters. + scale = btoi (clgetb ("scale")) + if (scale == YES) { + if (clgetb ("autoscale")) + autoscale = YES + else { + bscale = clgetd ("bscale") + bzero = clgetd ("bzero") + autoscale = NO + } + } else { + autoscale = NO + bscale = 1.0d0 + bzero = 0.0d0 + } + + # Get the output file name and type (tape or disk). If no tape file + # number is given for output, the user is asked if the tape is blank + # or contains data. If the tape is blank output begins at BOT, + # otherwise at EOT. + + call clgstr ("fextn", fextn, SZ_FNAME) + ch = '.' + if (make_image == YES) { + call clgstr ("fits_files", fits_files, SZ_FNAME) + if (mtfile (fits_files) == YES) { + flist = NULL + if (mtneedfileno (fits_files) == YES) { + newtape = clgetb ("newtape") + if (newtape) + call mtfname (fits_files, 1, out_fname, SZ_FNAME) + else + call mtfname (fits_files, EOT, out_fname, SZ_FNAME) + } else { + call strcpy (fits_files, out_fname, SZ_FNAME) + newtape = false + } + } else { + flist = fntopnb (fits_files, NO) + nfiles = fntlenb (flist) + if (wextensions == YES && nfiles > 1) + call error (0, + "Only one output FITS extensions file can be written") + if ((nfiles > 1) && (nfiles != nimages)) + call error (0, + "T_WFITS: Input and output lists are not the same length") + } + } else { + fits_files[1] = EOS + flist = NULL + } + + # Get the fits file blocking factor. + blkfac = wft_blkfac (fits_files, clgeti ("blocking_factor")) + + # Loop through the list of input images files. + + file_number = 1 + while (imtgetim (imlist, in_fname, SZ_FNAME) != EOF) { + + # Get the output file name. If single file output to disk, use + # name fits_file. If multiple file output to disk, the file number + # is added to the output file name, if no output name list is + # supplied. If an output name list is supplied then the names + # are extracted one by one from that list. + + if (make_image == YES) { + if (mtfile (fits_files) == YES) { + if (wextensions == NO && file_number == 2) + call mtfname (out_fname, EOT, out_fname, SZ_FNAME) + } else if (nfiles > 1) { + if (fntgfnb (flist, out_fname, SZ_FNAME) == EOF) + call error (0, "Error reading output file name") + if (fextn[1] != EOS) { + addext = OK + index = strldx (ch, out_fname) + if (index > 0) { + if (streq (fextn, out_fname[index+1])) + addext = ERR + else + addext = OK + } + if (addext == OK){ + call strcat (".", out_fname, SZ_FNAME) + call strcat (fextn, out_fname, SZ_FNAME) + } + } + } else { + if (fntrfnb (flist, 1, out_fname, SZ_FNAME) == EOF) + call strcpy (fits_files, out_fname, SZ_FNAME) + if (nimages > 1 && wextensions == NO) { + call sprintf (out_fname[strlen(out_fname)+1], SZ_FNAME, + "%04d") + call pargi (file_number) + } + if (fextn[1] != EOS) { + addext = OK + index = strldx (ch, out_fname) + if (index > 0) { + if (streq (fextn, out_fname[index+1])) + addext = ERR + else + addext = OK + } + if (addext == OK){ + call strcat (".", out_fname, SZ_FNAME) + call strcat (fextn, out_fname, SZ_FNAME) + } + } + } + } + + # Write each output file. + iferr (call wft_write_fitz (in_fname, out_fname, file_number, + nimages)) { + call printf ("Error writing file: %s\n") + call pargstr (out_fname) + call erract (EA_WARN) + break + } else + file_number = file_number + 1 + } + + # Close up the input and output lists. + call clpcls (imlist) + if (flist != NULL) + call fntclsb (flist) +end + + +# WFT_GET_BITPIX -- This procedure fetches the user determined bitpix or ERR if +# the bitpix is not one of the permitted FITS types. + +int procedure wft_get_bitpix (bitpix) + +int bitpix + +begin + switch (bitpix) { + case FITS_BYTE, FITS_SHORT, FITS_LONG, FITS_REAL, FITS_DOUBLE: + return (bitpix) + default: + return (ERR) + } +end + + +# WFT_BLKFAC -- Get the fits tape blocking factor. + +int procedure wft_blkfac (file, ublkfac) + +char file[ARB] # the input file name +int ublkfac # the user supplied blocking factor + +int bs, fb, blkfac +pointer gty +int mtfile(), mtcap(), gtygeti() +errchk mtcap(), gtygeti() + +begin + # Return a blocking factor of 1 if the file is a disk file. + if (mtfile (file) == NO) + return (0) + + # Open the tapecap device entry for the given device, and get + # the device block size and default FITS blocking factor + # parameters. + + iferr (gty = mtcap (file)) + return (max (ublkfac,1)) + iferr (bs = gtygeti (gty, "bs")) { + call gtyclose (gty) + return (max (ublkfac,1)) + } + iferr (fb = max (gtygeti (gty, "fb"), 1)) + fb = 1 + + # Determine whether the device is a fixed or variable blocked + # device. Set the fits blocking factor to the value of the fb + # parameter if device is fixed block or if the user has + # requested the default blocking factor. Set the blocking factor + # to the user requested value if the device supports variable + # blocking factors. + + if (bs == 0) { + if (ublkfac <= 0) + blkfac = fb + else + blkfac = ublkfac + } else + blkfac = fb + + call gtyclose (gty) + + return (blkfac) +end diff --git a/pkg/dataio/fits/wfits.com b/pkg/dataio/fits/wfits.com new file mode 100644 index 00000000..04779ef3 --- /dev/null +++ b/pkg/dataio/fits/wfits.com @@ -0,0 +1,17 @@ +# FITS common block + +double bscale # FITS scaling factor +double bzero # FITS offset factor +int bitpix # Output bits per pixel +int len_record # Record length in FITS bytes +int long_header # Print long header? +int short_header # Print short header? +int make_image # Make a FITS image? +int scale # Scale the data with bzero and bscale? +int autoscale # Allow program to calculate bscale and bzero? +int blkfac # FITS tape blocking factor +int wextensions # Write a FITS extensions file +int gheader # Write a global FITS extensions file header + +common /wfitscom/ bscale, bzero, bitpix, len_record, long_header, short_header, + make_image, scale, autoscale, blkfac, wextensions, gheader diff --git a/pkg/dataio/fits/wfits.h b/pkg/dataio/fits/wfits.h new file mode 100644 index 00000000..a36caa89 --- /dev/null +++ b/pkg/dataio/fits/wfits.h @@ -0,0 +1,128 @@ +# WFITS header file + +# The basic FITS data structure + +define LEN_FITS (44 + SZ_FNAME + 1) + +define BSCALE Memd[P2D($1)] # FITS bscale value +define BZERO Memd[P2D($1+2)] # FITS bzero value +define TAPEMAX Memd[P2D($1+4)] # IRAF tape max +define TAPEMIN Memd[P2D($1+6)] # IRAF tape min +define IRAFMAX Memr[P2R($1+8)] # IRAF image maximum +define IRAFMIN Memr[P2R($1+9)] # IRAF image minimum +define BLANK Meml[P2L($1+10)] # FITS blank value +define FITS_BITPIX Memi[$1+11] # FITS bits per pixel +define DATA_BITPIX Memi[$1+12] # Data bits per pixel +define SCALE Memi[$1+13] # Scale data? +define XTENSION Memi[$1+14] # FITS extension type +define BLANK_STRING Memc[P2C($1+19)] # String containing FITS blank value +define TYPE_STRING Memc[P2C($1+31)] # String containing IRAF type +define IRAFNAME Memc[P2C($1+41)] # IRAF file name + + +# Define the FITS record size + +define FITS_RECORD 2880 # Size of standard FITS record (bytes) + +# Define the supported FITS extensions + +define EXT_PRIMARY 1 # the primary data array +define EXT_IMAGE 2 # the image extension + +# Define the FITS data types + +define FITS_BYTE 8 # Number of bits in a FITS byte +define FITS_SHORT 16 # Number of bits in a FITS short +define FITS_LONG 32 # Number of bits in a FITS long +define FITS_REAL -32 # Number of bits in a FITS real * -1 +define FITS_DOUBLE -64 # Number of bits in a FITS double * -1 + +# Define the FITS precision in decimal digits + +define BYTE_PREC 3 # Precision of FITS byte +define SHORT_PREC 5 # Precision of FITS short +define LONG_PREC 10 # Precision of FITS long + +# Define the FITS blank data values + +define BYTE_BLANK 0.0d0 # Blank value for a FITS byte +define SHORT_BLANK -3.2768d4 # Blank value for a FITS short +define LONG_BLANK -2.147483648d9 # Blank value for a FITS long +#define BYTE_BLANK 0 # Blank value for a FITS byte +#define SHORT_BLANK -32768 # Blank value for a FITS short +#define LONG_BLANK -2147483648 # Blank value for a FITS long + +# Define the FITS integer max and min values + +define BYTE_MAX 2.55d2 # Max value for a FITS byte +define BYTE_MIN 1.0d0 # Min value for a FITS byte +define SHORT_MAX 3.2767d4 # Max value for a FITS short +define SHORT_MIN -3.2767d4 # Min value for a FITS short +define LONG_MAX 2.147483647d9 # Max value for a FITS long +define LONG_MIN -2.147483647d9 # Min value for a FITS long +define PREC_RATIO .99978637d0 # Tape span reduction factor + +# Define the FITS card image parameters + +define LEN_CARD 80 # Length of FITS header card +define LEN_KEYWORD 8 # Length of FITS keyword +define LEN_NAXIS_KYWRD 5 # Length of the NAXIS keyword string +define COL_VALUE 11 # First column of value field + +# Mapping of FITS task keywords to IRAF image header keywords + +define NAXIS IM_NDIM($1) # Number of dimensions +define NAXISN IM_LEN($1, $2) # Length of each dimension +define OBJECT IM_TITLE($1) # Image title +define HISTORY IM_HISTORY($1) # History +define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] # IRAF user area + +define PIXTYPE IM_PIXTYPE($1) # Image pixel type +define NBPIX IM_NBPIX($1) # Number of bad pixels +define LIMTIME IM_LIMTIME($1) # Last modify limits time +define MTIME IM_MTIME($1) # Last modify time +define CTIME IM_CTIME($1) # Create time + +define LEN_USERAREA 28800 # Default user area size + +# Set up a structure for the WFITS parameters + +# Define the required keywords + +define FIRST_CARD 1 # FITS simple/xtension parameter +define SECOND_CARD 2 # FITS bitpix parameter +define THIRD_CARD 3 # FITS naxis parameter + +# Define the optional FITS KEYWORD parameters + +define NOPTIONS 15 # Number of optional keywords + +define KEY_EXTEND 1 # FITS EXTEND keyword +define KEY_PCOUNT 2 # Number of random parameter +define KEY_GCOUNT 3 # Number of groups +define KEY_BSCALE 4 # FITS bscale parameter +define KEY_BZERO 5 # FITS bzero parameter +define KEY_BUNIT 6 # FITS physical units +define KEY_BLANK 7 # FITS value of blank pixel +define KEY_OBJECT 8 # FITS title string +define KEY_ORIGIN 9 # Origin of FITS tape +define KEY_DATE 10 # Date the tape was written +define KEY_IRAFNAME 11 # Root name of IRAF image +define KEY_IRAFMAX 12 # Maximum value of IRAF image +define KEY_IRAFMIN 13 # Minimum value of IRAF image +define KEY_IRAFBP 14 # Bits per pixel in IRAF image +define KEY_IRAFTYPE 15 # IRAF image data type + +define LEN_STRING 8 # Minimum length of a string parameter +define LEN_DATE 19 # Length of the new date string +define LEN_OBJECT 63 # Maximum length of string parameter +define LEN_ALIGN 18 # Maximum length for aligning parameter +define LEN_ORIGIN 9 # Length of origin string +define LEN_BLANK 11 # Length of the blank string +define NDEC_REAL 7 # Precision of real data +define NDEC_DOUBLE 11 # Precision of double precision data + +# Miscellaneous + +define CENTURY 1900 +define NEW_CENTURY 2000 diff --git a/pkg/dataio/import.par b/pkg/dataio/import.par new file mode 100644 index 00000000..ba2792c1 --- /dev/null +++ b/pkg/dataio/import.par @@ -0,0 +1,30 @@ +# IMPORT Task Parameter File +binfiles,s,a,"",,,"The list of input binary files to be read" +images,s,a,"",,,"The list of output IRAF images to be written" +format,s,h,"sense",,,"The type of format to be processed + + INPUT PARAMETERS +" +dims,s,h,"",,,"Input file dimension string" +pixtype,s,h,"",,,"Input pixel type" +interleave,i,h,0,,,"Pixel interleave type" +bswap,s,h,"no","|no|yes|i2|i4||",,"Byte-swap flag" +hskip,i,h,0,,,"Bytes preceeding pixel data to skip" +tskip,i,h,0,,,"Bytes to skip at end of file" +bskip,i,h,0,,,"Bytes between image bands to skip" +lskip,i,h,0,,,"Bytes to skip at font of each line" +lpad,i,h,0,,,"Bytes to skip at end of each line + + OUTPUT PARAMETERS +" +output,s,h,"image","|none|image|list|info|",,"Type of output to generate" +outtype,s,h,"s","|u|s|i|l|r|d||",,"The data type of the output image" +outbands,s,h,"",,,"Output image band expressions" +imheader,s,h,"",,,"File of FITS-like header info to add +" +database,s,h,"dataio$import/images.dat",,,"Format database" +verbose,b,h,no,,,"Verbose output during conversion?" + +# Mode parameter +buffer_size,i,h,64,,,"Number of image lines to buffer in memory" +mode,s,h,"ql",,,"mode parameter" diff --git a/pkg/dataio/import/README b/pkg/dataio/import/README new file mode 100644 index 00000000..20ab02a1 --- /dev/null +++ b/pkg/dataio/import/README @@ -0,0 +1,2 @@ +This directory contains the source code for the IMPORT -to-IRAF +format conversion task. diff --git a/pkg/dataio/import/bltins/README b/pkg/dataio/import/bltins/README new file mode 100644 index 00000000..c15b9cfe --- /dev/null +++ b/pkg/dataio/import/bltins/README @@ -0,0 +1,13 @@ + This directory contains the source code for the 'builtin' formats +converted with IMPORT. Here we implement three formats that require different +levels of processing: the GIF format uses LZW compression and a colormap for +pixel storage and requires the most work, Sun Rasterfiles have various formats +that may require colormap application or RLE decoding, and lastly the X +Window Dump format that fits the generic binary raster model with the exception +of an 8-bit file with a colormap. + Because formats are defined in the data base the user is unaware of +any special processing that occurs unless implementing a new format that +requires partivular handling. In the case of colormap files the example of +XWD can be followed and all that's needed is a routine to read the colormap +from the image. 'Builtin' formats must, however, be declared in the source +import$ipbuiltin.x to route execution to the format-specific code. diff --git a/pkg/dataio/import/bltins/ipcmap.x b/pkg/dataio/import/bltins/ipcmap.x new file mode 100644 index 00000000..ad44a7cf --- /dev/null +++ b/pkg/dataio/import/bltins/ipcmap.x @@ -0,0 +1,76 @@ +include "../import.h" + +# IPCMAP.X -- Procedures for colormap application or lookup. + + +# IP_GRAY_CMAP - Apply the colormap to an array of pixels and convert the +# pixels to grayscale using the NTSC formula. + +procedure ip_gray_cmap (data, len, cmap) + +char data[ARB] #i pixel values +int len #i how many of 'em +pointer cmap #i colormap pointer + +int i +short val, ip_gcmap_val() + +begin + do i = 1, len { + val = data[i] + 1 + data[i] = ip_gcmap_val (val, cmap) + } +end + + +# IP_GCMAP_VAL - Apply the colormap to a single pixel and convert the +# result to grayscale using the NTSC formula. + +short procedure ip_gcmap_val (pix, cmap) + +char pix #i pixel value +pointer cmap #i colormap pointer + +short val + +begin + val = (R_COEFF * CMAP(cmap,IP_RED,pix) + + G_COEFF * CMAP(cmap,IP_GREEN,pix) + + B_COEFF * CMAP(cmap,IP_BLUE,pix)) + return (val) +end + + +# IP_RGB_VAL - Given a grayscale value figure out what the requested color +# component is from the colormap. + +short procedure ip_rgb_val (pix, cmap, color) + +char pix #i pixel value +pointer cmap #i colormap pointer +int color #i requested color + +short i, val + +begin + # Need to optimize this later... For now just compute the colormap + # grayscale values until we find a match and use the index. + i = 0 + val = -1 + while (val != pix && i <= 256) { + i = i + 1 + val = (R_COEFF * CMAP(cmap,IP_RED,i) + + G_COEFF * CMAP(cmap,IP_GREEN,i) + + B_COEFF * CMAP(cmap,IP_BLUE,i)) + } + + switch (color) { + case IP_RED: + val = CMAP(cmap,IP_RED,i-1) + case IP_GREEN: + val = CMAP(cmap,IP_GREEN,i-1) + case IP_BLUE: + val = CMAP(cmap,IP_BLUE,i-1) + } + return (val) +end diff --git a/pkg/dataio/import/bltins/ipgif.x b/pkg/dataio/import/bltins/ipgif.x new file mode 100644 index 00000000..a7394e18 --- /dev/null +++ b/pkg/dataio/import/bltins/ipgif.x @@ -0,0 +1,883 @@ +include "../import.h" + + +# IPGIF.X - Source file for the GIF builtin format converter. + + +# Define the GIF data structure +define MAX_CODE_ENTRIES 4096 # because LZW has 12 bit max +define SZ_GIFSTRUCT 35 +define SZ_GIFCODE 280 +define SZ_GIFEXTN 256 +define SZ_GIFSTACK (2*MAX_CODE_ENTRIES+2) +define SZ_GIFCTAB (2*MAX_CODE_ENTRIES+2) + +define GIF_FD Memi[$1] # GIF file descriptor +define GIF_WIDTH Memi[$1+1] # Screen width +define GIF_HEIGHT Memi[$1+2] # Screen height +define GIF_CP Memi[$1+3] # Colormap pointer +define GIF_BITPIX Memi[$1+4] # Bits per pixel +define GIF_COLRES Memi[$1+5] # Color resolution +define GIF_BACKGROUND Memi[$1+6] # background color (unused?) +define GIF_ASPECT Memi[$1+7] # Aspect ratio +define GIF_IMNUM Memi[$1+8] # Image number +define GIF_CMAP Memi[$1+9] # Global colormap (ptr) + +define GIF_EXTBP Memi[$1+10] # Extension buffer (ptr) +define GIF_CODEP Memi[$1+11] # Code table buffer (ptr) +define GIF_CTABP Memi[$1+12] # Code table (ptr) +define GIF_STACKP Memi[$1+13] # Stack (ptr) +define GIF_CURBIT Memi[$1+14] # Decoder var +define GIF_LASTBIT Memi[$1+15] # Decoder var +define GIF_DONE Memi[$1+16] # Decoder var +define GIF_LASTBYTE Memi[$1+17] # Decoder var +define GIF_ZERO_DATABLOCK Memi[$1+18] # Decoder var +define GIF_SP Memi[$1+19] # stack pointer + +define GIF_CLEAR_CODE Memi[$1+20] # LZW clear code +define GIF_END_CODE Memi[$1+21] # LZW end code +define GIF_FIRST_CODE Memi[$1+22] # LZW decoder var +define GIF_OLD_CODE Memi[$1+23] # LZW decoder var +define GIF_MAX_CODE Memi[$1+24] # LZW free code +define GIF_MAX_CODE_SIZE Memi[$1+25] # LZW upper limit +define GIF_CODE_SIZE Memi[$1+26] # LZW current code size +define GIF_SET_CODE_SIZE Memi[$1+27] # LZW input code size +define GIF_FRESH Memi[$1+28] # LZW init var + +# The following are used for GIF89a only. +define GIF_TRANSPARENT Memi[$1+30] # Transparent Color Index +define GIF_DELAYTIME Memi[$1+31] # Delay time +define GIF_INPUTFLAG Memi[$1+32] # User input flag +define GIF_DISPOSAL Memi[$1+33] # Disposal Method + +# Array macros. +define CODEBUF Memc[GIF_CODEP($1)+$2] +define EXTBUF Memc[GIF_EXTBP($1)+$2] +define CODETAB Memc[GIF_CTABP($1)+($2*MAX_CODE_ENTRIES)+$3] +define STACK Memc[GIF_STACKP($1)+$2] + +#--------------------------------------------------------------------------- + +define INTERLACE 040X # Image descriptor flags +define LOCAL_COLORMAP 080X + +# Define the flags for the GIF89a extension blocks. +define GE_PLAINTEXT 001X # Plain Text Extension +define GE_APPLICATION 0FFX # Application Extension +define GE_COMMENT 0FEX # Comment Extension +define GE_GCONTROL 0F9X # Graphics Control Extension + +define DEBUG false +define VDEBUG false + + +# IP_GIF - Read and process a GIF format file into an IRAF image. + +procedure ip_gif (ip, fname, info_only, verbose) + +pointer ip #i import struct pointer +char fname[ARB] #i file name +int info_only #i print out image info only? +int verbose #i verbosity flag + +pointer gif +int fd +int bitpix, use_global_cmap, interlace +int width, height, version +char ch +short sig[7], screen[12] + +pointer gif_open() +int btoi(), strncmp(), gif_rdbyte(), gif_getbytes() +int shifti() + +long filepos +common /gifcom/ filepos + +begin + # Allocate the gif struct pointer. + gif = gif_open() + GIF_FD(gif) = IP_FD(ip) + fd = GIF_FD(gif) + + # The GIF signature is verified in the database file but check it + # here anyway. + filepos = 1 + call ip_lseek (fd, BOF) + if (gif_getbytes(fd, sig, 6) != OK) + call error (0, "Error reading GIF magic number.") + if (strncmp(sig[4],"87a",3) == 0) + version = 87 + else if (strncmp(sig[4],"89a",3) == 0) + version = 89 + else + call error (0, "Bad version: File is not a GIF 87a or 89A") + + # Now read the screen descriptor. + if (gif_getbytes(fd, screen, 7) != OK) + call error (0, "Error reading screen descriptor.") + + GIF_WIDTH(gif) = screen[1] + (256 * screen[2]) + GIF_HEIGHT(gif) = screen[3] + (256 * screen[4]) + GIF_BITPIX(gif) = shifti (2, and(int(screen[5]),07X)) + GIF_COLRES(gif) = shifti (and(int(screen[5]), 070X), -3) + 1 + GIF_BACKGROUND(gif) = screen[6] + GIF_ASPECT(gif) = screen[7] + if (DEBUG) { + call eprintf ("w:%d h:%d bpix:%d ncol:%d bkg:%d asp:%d\n") + call pargi(GIF_WIDTH(gif)); call pargi(GIF_HEIGHT(gif)) + call pargi(GIF_BITPIX(gif)); call pargi(GIF_COLRES(gif)) + call pargi(GIF_BACKGROUND(gif)); call pargi(GIF_ASPECT(gif)) + call flush (STDERR) + } + + # We'll set the buffer size to the full image to speed processing. + IP_SZBUF(ip) = GIF_HEIGHT(gif) + + # See if we have a global colormap. + if (and (int(screen[5]), LOCAL_COLORMAP) > 0) + call gif_rdcmap (gif, GIF_BITPIX(gif), GIF_CMAP(gif)) + IP_CMAP(ip) = GIF_CMAP(gif) + + # Now process the rest of the image blocks. + GIF_IMNUM(gif) = 0 + repeat { + if (gif_rdbyte(fd, ch) != OK) { + call error (0, "Bad data read.") + } + + if (ch == ';') { # GIF terminator + break + } + + if (ch == '!') { # Extension block + # Read the extension function code. + if (gif_rdbyte(fd, ch) != OK) + call error (0, "Bad data read.") + call gif_extension (gif, ch, IP_VERBOSE(ip)) + next + } + + if (ch != ',') { # not a valid start character + if (ch != '\0') { # quietly allow a NULL block + call eprintf ("Ignoring bogus start char 0x%02x.") + call pargc (ch) + } + next + } + + # Read the current image descriptor block. There may be more + # than one image in a file so we'll just copy each image into + # a separate band of the output image (should be rare). + GIF_IMNUM(gif) = GIF_IMNUM(gif) + 1 + if (gif_getbytes (fd, screen, 9) != OK) + call error (0, "Bad scene descriptor") + + # See if this image has a local colormap. There supposedly aren't + # a lot of files that use this (GIF89a only) but we'll read it + # anyway so we don't get stung on file positioning. + if (and (int(screen[9]), LOCAL_COLORMAP) == LOCAL_COLORMAP) + use_global_cmap = NO + else + use_global_cmap = YES + + # Unpack the image descriptor into useful things. + bitpix = shifti (1, (and (int(screen[9]), 07X) + 1)) + interlace = btoi (and (int(screen[9]), INTERLACE) == INTERLACE) + width = screen[5] + (screen[6] * 256) + height = screen[7] + (screen[8] * 256) + if (DEBUG) { + call eprintf ("global_cmap:%d bitpix:%d ") + call pargi(use_global_cmap); call pargi(bitpix) + call eprintf ("interlace:%d w:%d h:%d\n") + call pargi(interlace); call pargi(width); call pargi(height) + } + + if (info_only == NO) { + if (use_global_cmap == NO) { + # Process the image with a local colormap. + call gif_rdcmap (gif, bitpix, GIF_CMAP(gif)) + call gif_read_image (ip, gif, width, height, + GIF_CMAP(gif), interlace) + } else { + # Process the image with the global colormap. + call gif_read_image (ip, gif, width, height, + GIF_CMAP(gif), interlace) + } + } else { + call ip_gif_info (ip, fname, version, width, height, + GIF_BITPIX(gif), use_global_cmap, interlace, verbose) + break + } + } + + # Clean up. + call gif_close (gif) + IP_CMAP(ip) = NULL +end + + +# IP_GIF_INFO - Print information about the GIF file. + +procedure ip_gif_info (ip, fname, version, width, height, colres, global, + interlace, verbose) + +pointer ip #i task struct pointer +char fname[ARB] #i file name +int version #i GIF version +int width, height #i image dimensions +int colres #i number of colormap entries +int global #i image has global colormap +int interlace #i image is interlaced +int verbose #i verbosity flag + +begin + # If not verbose print a one-liner. + if (verbose == NO) { +# call printf ("Input file:\n\t") + call printf ("%s: %20t%d x %d \t\tCompuServe GIF %da format file\n") + call pargstr (fname) + call pargi (width) + call pargi (height) + call pargi (version) + + # Print out the format comment if any. +# if (IP_COMPTR(ip) != NULL) { +# if (COMMENT(ip) != '\0') { +# call printf ("%s\n") +# call pargstr (COMMENT(ip)) +# } +# call strcpy ("\0", COMMENT(ip), SZ_LINE) +# } + return + } + + # Print a more verbose description. + call printf ("%s: %20tCompuServe GIF %da Format File\n") + call pargstr (fname) + call pargi (version) + + # Print out the format comment if any. + if (IP_COMPTR(ip) != NULL) { + if (COMMENT(ip) != '\0') { + call printf ("%s\n") + call pargstr (COMMENT(ip)) + } + call strcpy ("\0", COMMENT(ip), SZ_LINE) + } + + call printf ("%20tResolution:%38t%d x %d\n") + call pargi (width) + call pargi (height) + + call printf ("%20tPixel storage: %38t%s\n") + if (interlace == YES) + call pargstr ("Interlaced order") + else + call pargstr ("Sequential order") + + call printf ("%20tByte Order: %38t%s\n") + call pargstr ("LSB first") + + call printf ("%20tType: %38t%s\n") + call pargstr ("8-bit Color indexed") + + call printf ("%20t%s Colormap: %38t%d entries\n") + if (global == YES) + call pargstr ("Global") + else + call pargstr ("Local") + call pargi (colres) + + call printf ("%20tCompression: %38t%s\n") + call pargstr ("Lempel-Ziv and Welch (LZW)") +end + + +# GIF_OPEN - Open the GIF structure descriptor. + +pointer procedure gif_open () + +pointer gif + +begin + iferr (call calloc (gif, SZ_GIFSTRUCT, TY_STRUCT)) + call error (0, "Error allocating GIF structure.") + + # Allocate the extension and code buffers. + iferr (call calloc (GIF_CODEP(gif), SZ_GIFCODE, TY_CHAR)) + call error (0, "Error allocating GIF code buffer pointer.") + iferr (call calloc (GIF_EXTBP(gif), SZ_GIFEXTN, TY_CHAR)) + call error (0, "Error allocating GIF extension pointer.") + iferr (call calloc (GIF_CTABP(gif), SZ_GIFCTAB, TY_CHAR)) + call error (0, "Error allocating code table pointer.") + iferr (call calloc (GIF_STACKP(gif), SZ_GIFSTACK, TY_CHAR)) + call error (0, "Error allocating GIF stack pointer.") + + # Initialize some of the variables to non-zero values. + GIF_ZERO_DATABLOCK(gif) = NO + GIF_TRANSPARENT(gif) = -1 + GIF_DELAYTIME(gif) = -1 + GIF_INPUTFLAG(gif) = -1 + + return (gif) +end + + +# GIF_CLOSE - Close the GIF structure descriptor. + +procedure gif_close (gif) + +pointer gif #i GIF struct pointer + +begin + call mfree (GIF_STACKP(gif), TY_CHAR) + call mfree (GIF_CTABP(gif), TY_CHAR) + call mfree (GIF_EXTBP(gif), TY_CHAR) + call mfree (GIF_CODEP(gif), TY_CHAR) + + if (GIF_CMAP(gif) != NULL) + call mfree (GIF_CMAP(gif), TY_CHAR) + call mfree (gif, TY_STRUCT) +end + + +# GIF_READ_IMAGE - Read the image raster from the file. Decompress the +# LZW compressed data stream into 8-bit pixels. + +procedure gif_read_image (ip, gif, width, height, cmap, interlace) + +pointer ip #i task struct pointer +pointer gif #i GIF struct pointer +int width, height #i image dimensions +pointer cmap #i colormap pointer +int interlace #i interlace flag + +pointer im, op, out, data +char csize, pix, val +int i, v, xpos, ypos, pass +int nlines, line, percent + +pointer ip_evaluate() +int gif_rdbyte(), gif_lzw_rdbyte() +short ip_gcmap_val() + +begin + # Get the initial code_size for the compression routines. + if (gif_rdbyte(GIF_FD(gif), csize) != OK) + call error (0, "EOF or read error on image data.") + call gif_lzw_init (gif, csize) + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + im = IP_IM(ip) + op = PTYPE(ip,GIF_IMNUM(gif)) + call malloc (data, width, TY_CHAR) + IO_DATA(op) = data + IO_NPIX(op) = width + + # Get the pixels. + xpos = 0 + ypos = 0 + pass = 0 + nlines = 0 + percent = 0 + repeat { + v = gif_lzw_rdbyte (gif) + if (v < 0) + break # at the EOF + else { + if (cmap != NULL && IP_USE_CMAP(ip) == YES) { + # Apply the colormap since this is just an index. + val = v + 1 + pix = ip_gcmap_val (val, cmap) + } else + pix = char (v) + Memc[data+xpos] = pix # assign the pixel + } + + xpos = xpos + 1 + if (xpos == width) { + xpos = 0 + nlines = nlines + 1 + + # Evaluate outbands expression. + do i = 1, IP_NBANDS(ip) { + out = ip_evaluate (ip, O_EXPR(ip,i)) + + # Write bands to output image + if (IP_OUTPUT(ip) != IP_NONE) { + line = ypos + 1 + call ip_wrline (ip, im, out, GIF_WIDTH(gif), line, + (GIF_IMNUM(gif)-1)*IP_NBANDS(ip)+i) + } + call evvfree (out) + } + + # Print percent done if being verbose + if (IP_VERBOSE(ip) == YES) { + if (nlines * 100 / height >= percent + 10) { + percent = percent + 10 + call printf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDOUT) + } + } + + # if the image is interlaced adjust the line number accordingly, + # otherwise just increment it. + if (interlace == YES) { + switch (pass) { + case 0, 1: + ypos = ypos + 8 + case 2: + ypos = ypos + 4 + case 3: + ypos = ypos + 2 + } + + if (ypos >= height) { + pass = pass + 1 + switch (pass) { + case 1: + ypos = 4 + case 2: + ypos = 2 + case 3: + ypos = 1 + } + } + } else { + # Non-interlaced GIF so just increment the line number. + ypos = ypos + 1 + } + } + } + + if (IP_VERBOSE(ip) == YES) { + call printf (" Status: Done \n") + call flush (STDOUT) + } + + # Clean up the data pointer. + call mfree (data, TY_CHAR) +end + + +# GIF_RDCMAP - Read a colormap (local or global) from the GIF file. + +procedure gif_rdcmap (gif, ncolors, cmap) + +pointer gif #i GIF struct pointer +int ncolors #i number of colors to read +pointer cmap #u local or global colormap ptr + +int i +char rgb[3] +int gif_getbytes() + +begin + if (cmap == NULL) + iferr (call calloc (cmap, 3*CMAP_SIZE, TY_CHAR)) + call error (0, "Error allocating color map.") + + do i = 1, ncolors { + # Read RGB colors. + if (gif_getbytes (GIF_FD(gif), rgb, 3) != OK) + call error (0, "Bad GIF colormap - not enough colors.") + + # Load the colormap. + CMAP(cmap,IP_RED,i) = rgb[1] + CMAP(cmap,IP_GREEN,i) = rgb[2] + CMAP(cmap,IP_BLUE,i) = rgb[3] + } +end + + +# GIF_EXTENSION - Process a GIF extension block. For now we'll just ignore +# these when converting the image but read the data blocks anyway. We should +# still be able to read the image but won't take advantage of the GIF89a +# extensions. + +procedure gif_extension (gif, label, verbose) + +pointer gif #i Gif struct pointer +char label #i GIF extension label +int verbose #i print verbose info? + +pointer sp, buf +int val +int and(), gif_get_data_block() + +begin + call smark (sp) + call salloc (buf, SZ_GIFCODE, TY_CHAR) + + switch (label) { + case GE_PLAINTEXT: # Plain Text Extension + if (verbose == YES) { + call eprintf ("Warning: Ignoring a Plain Text Extension.\n") + call flush (STDERR) + } + case GE_APPLICATION: # Application Extension + if (verbose == YES) { + call eprintf ("Warning: Ignoring an Application Extension.\n") + call flush (STDERR) + } + case GE_COMMENT: # Comment Extension + # Simply print out the comment. + while (gif_get_data_block (gif, Memc[buf]) != 0) { + if (verbose == YES) { + call printf ("Comment: %s\n") + call pargstr (Memc[buf]) + } + } + call sfree (sp) + return + case GE_GCONTROL: # Graphic Control Extension + # Process the graphic control block. + val = gif_get_data_block (gif, Memc[buf]) + GIF_DISPOSAL(gif) = and (int(Memc[buf]/4), 07X) + GIF_INPUTFLAG(gif) = and (int(Memc[buf]/2), 01X) + GIF_DELAYTIME(gif) = Memc[buf+1] + (256 * Memc[buf+2]) + if (and(int(Memc[buf]),01X) == 1) + GIF_TRANSPARENT(gif) = Memc[buf+3] + + while (gif_get_data_block (gif, Memc[buf]) != 0) + ; + + call sfree (sp) + return + default: + call eprintf ("Warning: Unknown extension label (0x%02x).\n") + call pargc (label) + call flush (STDERR) + } + + # If we get here then we've ignored an extension but still need to + # eat the data blocks. + while (gif_get_data_block (gif, Memc[buf]) != 0) + ; + + call sfree (sp) +end + + +# GIF_LZW_INIT - Initialize the LZW decompression variables. + +procedure gif_lzw_init (gif, input_code_size) + +pointer gif #i GIF struct pointer +char input_code_size #i input code size + +int i, shifti() + +begin + GIF_SET_CODE_SIZE(gif) = input_code_size + GIF_CODE_SIZE(gif) = GIF_SET_CODE_SIZE(gif) + 1 + GIF_CLEAR_CODE(gif) = shifti (1, GIF_SET_CODE_SIZE(gif)) + GIF_END_CODE(gif) = GIF_CLEAR_CODE(gif) + 1 + GIF_MAX_CODE_SIZE(gif) = 2 * GIF_CLEAR_CODE(gif) + GIF_MAX_CODE(gif) = GIF_CLEAR_CODE(gif) + 2 + + GIF_CURBIT(gif) = 0 # initialize the code vars + GIF_LASTBIT(gif) = 0 + GIF_DONE(gif) = NO + + GIF_FRESH(gif) = YES + + # Initialize the code table. + for (i = 0; i < GIF_CLEAR_CODE(gif); i=i+1) { + CODETAB(gif,0,i) = 0 + CODETAB(gif,1,i) = i + } + for (; i < MAX_CODE_ENTRIES; i=i+1) { + CODETAB(gif,0,i) = 0 + CODETAB(gif,1,0) = 0 + } + + GIF_SP(gif) = 0 +end + + + +# GIF_LZW_RDBYTE - + +int procedure gif_lzw_rdbyte (gif) + +pointer gif #i GIF struct pointer + +pointer sp, buf +int i, count +int code, incode + +int gif_get_code(), gif_get_data_block() + +begin + if (GIF_FRESH(gif) == YES) { + GIF_FRESH(gif) = NO + repeat { + GIF_OLD_CODE(gif) = gif_get_code (gif, GIF_CODE_SIZE(gif)) + GIF_FIRST_CODE(gif) = GIF_OLD_CODE(gif) + } until (GIF_FIRST_CODE(gif) != GIF_CLEAR_CODE(gif)) + return (GIF_FIRST_CODE(gif)) + } + + if (GIF_SP(gif) > 0) { + GIF_SP(gif) = GIF_SP(gif) - 1 + return (STACK(gif,GIF_SP(gif))) + } + + code = gif_get_code (gif, GIF_CODE_SIZE(gif)) + while (code >= 0) { + + # The Clear Code sets everything back to its initial value, then + # reads the immediately subsequent code as uncompressed data. + if (code == GIF_CLEAR_CODE(gif)) { + for (i = 0; i < GIF_CLEAR_CODE(gif); i=i+1) { + CODETAB(gif,0,i) = 0 + CODETAB(gif,1,i) = i + } + for ( ; i < MAX_CODE_ENTRIES; i=i+1) { + CODETAB(gif,0,i) = 0 + CODETAB(gif,1,i) = 0 + } + GIF_CODE_SIZE(gif) = GIF_SET_CODE_SIZE(gif) + 1 + GIF_MAX_CODE_SIZE(gif) = 2 * GIF_CLEAR_CODE(gif) + GIF_MAX_CODE(gif) = GIF_CLEAR_CODE(gif) + 2 + GIF_SP(gif) = 0 + GIF_OLD_CODE(gif) = gif_get_code (gif, GIF_CODE_SIZE(gif)) + GIF_FIRST_CODE(gif) = GIF_OLD_CODE(gif) + return (GIF_FIRST_CODE(gif)) + + # If this is the End Code we'll clean up a little before returning. + } else if (code == GIF_END_CODE(gif)) { + if (GIF_ZERO_DATABLOCK(gif) == YES) + return (ERR) + + call smark (sp) + call salloc (buf, 260, TY_CHAR) + + repeat { + count = gif_get_data_block (gif, Memc[buf]) + } until (count <= 0) + + if (count != 0) { + call eprintf ( + "Missing EOD in data stream (common occurance)") + } + call sfree (sp) + return (ERR) + } + + # Must be data so save it in incode. + incode = code + + # If it's greater or equal than the Free Code it's not in the hash + # table yet, repeat the last character decoded. + if (code >= GIF_MAX_CODE(gif)) { + STACK(gif, GIF_SP(gif)) = GIF_FIRST_CODE(gif) + GIF_SP(gif) = GIF_SP(gif) + 1 + code = GIF_OLD_CODE(gif) + } + + while (code >= GIF_CLEAR_CODE(gif)) { + STACK(gif, GIF_SP(gif)) = CODETAB(gif,1,code) + GIF_SP(gif) = GIF_SP(gif) + 1 + if (code == CODETAB(gif,0,code)) + call error (0, "Circular GIF code table entry.") + code = CODETAB(gif,0,code) + } + + GIF_FIRST_CODE(gif) = CODETAB(gif,1,code) + STACK(gif, GIF_SP(gif)) = GIF_FIRST_CODE(gif) + GIF_SP(gif) = GIF_SP(gif) + 1 + + if (VDEBUG) { + call eprintf("code=%d gmax=%d gmaxsz=%d 4096 old:%d frst:%d\n") + call pargi(code) ; call pargi(GIF_MAX_CODE(gif)) + call pargi(GIF_MAX_CODE_SIZE(gif)) + call pargi(GIF_OLD_CODE(gif)) + call pargi(GIF_FIRST_CODE(gif)) + } + + # Point to the next slot in the table. If we exceed the current + # MaxCode value, increment the code size unless it's already 12. + # If it is, do nothing: the next code decompressed better be CLEAR + + code = GIF_MAX_CODE(gif) + if (code < MAX_CODE_ENTRIES) { + CODETAB(gif,0,code) = GIF_OLD_CODE(gif) + CODETAB(gif,1,code) = GIF_FIRST_CODE(gif) + GIF_MAX_CODE(gif) = GIF_MAX_CODE(gif) + 1 + if ((GIF_MAX_CODE(gif) >= GIF_MAX_CODE_SIZE(gif)) && + (GIF_MAX_CODE_SIZE(gif) < MAX_CODE_ENTRIES)) { + GIF_MAX_CODE_SIZE(gif) = GIF_MAX_CODE_SIZE(gif) * 2 + GIF_CODE_SIZE(gif) = GIF_CODE_SIZE(gif) + 1 + } + } + + GIF_OLD_CODE(gif) = incode + + if (GIF_SP(gif) > 0) { + GIF_SP(gif) = GIF_SP(gif) - 1 + return (STACK(gif,GIF_SP(gif))) + } + + code = gif_get_code (gif, GIF_CODE_SIZE(gif)) + } + return code +end + + +# GIF_GET_CODE - Fetch the next code from the raster data stream. The codes +# can be any length from 3 to 12 bits, packed into 8-bit bytes, so we have to +# maintain our location in the Raster array as a BIT Offset. We compute the +# byte Offset into the raster array by dividing this by 8, pick up three +# bytes, compute the bit Offset into our 24-bit chunk, shift to bring the +# desired code to the bottom, then mask it off and return it. Simple. + +int procedure gif_get_code (gif, code_size) + +pointer gif #i GIF struct pointer +int code_size #i op code size + +int i, j, count, ret +int val1, val2 +int btoi(), and(), shifti(), ori () +int gif_get_data_block() + +begin + # See if processing the next code will overflow our buffer. If so + # we get the next control block from the stream. + if ( (GIF_CURBIT(gif) + code_size) >= GIF_LASTBIT(gif)) { + if (GIF_DONE(gif) == YES) { + if (GIF_CURBIT(gif) >= GIF_LASTBIT(gif)) { + call error (0, "GIF_GET_CODE: Ran out of bits.\n") + return (ERR) + } + } + + CODEBUF(gif,0) = CODEBUF(gif,GIF_LASTBYTE(gif)-2) + CODEBUF(gif,1) = CODEBUF(gif,GIF_LASTBYTE(gif)-1) + + count = gif_get_data_block (gif, CODEBUF(gif,2)) + if (count == 0) + GIF_DONE(gif) = YES + + GIF_LASTBYTE(gif) = 2 + count + GIF_CURBIT(gif) = (GIF_CURBIT(gif) - GIF_LASTBIT(gif)) + 16 + GIF_LASTBIT(gif) = (2 + count) * 8 + } + + # for (i = GIF_CURBIT(gif), j = 0; j < code_size; ++i, ++j) + # ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j; + + i = GIF_CURBIT(gif) + j = 0 + ret = 0 + while (j < code_size) { + val1 = btoi ( and (int(CODEBUF(gif,i/8)), shifti(1,mod(i,8))) != 0 ) + val2 = shifti (val1, j) + ret = ori (ret, val2) + i = i + 1 + j = j + 1 + } + + GIF_CURBIT(gif) = GIF_CURBIT(gif) + code_size + if (VDEBUG) { + call eprintf (": returning %d\n");call pargi(ret);call flush(STDERR) + } + + return (ret) +end + + +# GIF_GET_DATA_BLOCK - Get the next block of GIF data from the data stream so +# it can be converted to raster data. + +int procedure gif_get_data_block (gif, buf) + +pointer gif #i GIF struct pointer +char buf[ARB] #o data block + +char count +int nb, btoi() +int gif_rdbyte(), gif_getbytes() + +begin + if (gif_rdbyte (GIF_FD(gif), count) != OK) { + call error (0, "error in getting DataBlock size") + return (ERR) + } + + GIF_ZERO_DATABLOCK(gif) = btoi (count == 0) + if (VDEBUG) { + call eprintf ("getDataBlock: count = %d "); call pargs(count) } + nb = count + if ((count != 0) && (gif_getbytes(GIF_FD(gif), buf, nb) != OK)) { + call error (0, "error in reading DataBlock") + return (ERR) + } + return count +end + + + +# Byte I/O routines. We use the normal IMPORT procedures but localize the code +# here to make it easier to keep track of the current file position (in bytes). + +# GIF_RDBYTE - Read a single byte at the current offset from the file. + +int procedure gif_rdbyte (fd, val) + +int fd #i file descriptor +char val #o byte read + +short ip_getb() + +long filepos +common /gifcom/ filepos + +begin + iferr (val = ip_getb (fd, filepos)) + return (ERR) + + filepos = filepos + 1 + call ip_lseek (fd, filepos) + + return (OK) +end + + +# GIF_GETBYTES - Read an array of bytes from the file at the current offset. + +int procedure gif_getbytes (fd, buffer, len) + +int fd #i file descriptor +char buffer[ARB] #o output buffer +int len #i no. of bytes to read + +pointer sp, bp + +long filepos +common /gifcom/ filepos + +begin + call smark (sp) + call salloc (bp, len+1, TY_CHAR) + call aclrc (Memc[bp], len+1) + + call ip_agetb (fd, bp, len) # read the bytes + call amovc (Memc[bp], buffer, len) # copy to output buffer + filepos = filepos + len + call ip_lseek (fd, filepos) + + call sfree (sp) + return (OK) +end diff --git a/pkg/dataio/import/bltins/ipras.x b/pkg/dataio/import/bltins/ipras.x new file mode 100644 index 00000000..100ca6dc --- /dev/null +++ b/pkg/dataio/import/bltins/ipras.x @@ -0,0 +1,504 @@ +include +include "../import.h" + + +# IPRAS.X - Source file for the IMPORT task rasterfile builtin format. + + +define SZ_RASHDR 13 +define RAS_MAGIC Memi[$1] # Magic number +define RAS_WIDTH Memi[$1+1] # Image width (pixels per line) +define RAS_HEIGHT Memi[$1+2] # Image height (number of lines) +define RAS_DEPTH Memi[$1+3] # Image depth (bits per pixel) +define RAS_LENGTH Memi[$1+4] # Image length (bytes) +define RAS_TYPE Memi[$1+5] # File type +define RAS_MAPTYPE Memi[$1+6] # Colormap type +define RAS_MAPLENGTH Memi[$1+7] # Colormap length (bytes) + +define RAS_CMAP Memi[$1+10] # Colormap (ptr) +define RAS_COUNT Memi[$1+11] # RLE decoding var +define RAS_CH Memi[$1+12] # RLE decoding var + +# Rasterfile magic number +define RAS_MAGIC_NUM 59A66A95X +define RAS_RLE 80X + +# Sun supported ras_types +define RT_OLD 0 # Raw pixrect image in 68000 byte order +define RT_STANDARD 1 # Raw pixrect image in 68000 byte order +define RT_BYTE_ENCODED 2 # Run-length compression of bytes +define RT_FORMAT_RGB 3 # XRGB or RGB instead of XBGR or BGR +define RT_FORMAT_TIFF 4 # tiff <-> standard rasterfile +define RT_FORMAT_IFF 5 # iff (TAAC format) <-> standard rasterfile +define RT_EXPERIMENTAL 65535 # Reserved for testing + +# Sun supported ras_maptypes +define RMT_NONE 0 # ras_maplength is expected to be 0 +define RMT_EQUAL_RGB 1 # red[ras_maplength/3],green[],blue[] +define RMT_RAW 2 + + + +# IP_RAS - Read and process a Sun Rasterfile into an IRAF image. + +procedure ip_ras (ip, fname, info_only, verbose) + +pointer ip #i import struct pointer +char fname[ARB] #i file name +int info_only #i print out image info only? +int verbose #i verbosity flag + +pointer ras +int fd, w, nchars +pointer ras_open() + +long filepos +common /rascom/ filepos + +begin + # Allocate the ras struct pointer. + ras = ras_open () + fd = IP_FD(ip) + + # Initialize the file position. + filepos = 1 + call ip_lseek (fd, BOF) + + # Read in the rasterfile header, dump it directly to the task struct. + call ip_ageti (fd, ras, 8) + filepos = filepos + SZ_INT32 * SZB_CHAR * 8 + call ip_lseek (fd, filepos) + + # Now do some sanity checking on the values. + if (RAS_MAGIC(ras) != RAS_MAGIC_NUM) + call error (0, "Not a Sun rasterfile.") + if (RAS_TYPE(ras) == RT_OLD && RAS_LENGTH(ras) == 0) + RAS_LENGTH(ras) = RAS_WIDTH(ras) * RAS_HEIGHT(ras) * + RAS_DEPTH(ras) / 8 + + # See if we really want to convert this thing. + if (info_only == YES) { + call ip_ras_info (ip, ras, fname, verbose) + call ras_close (ras) + return + } + + # Get the colormap (if any). + call ras_rdcmap (fd, ras, RAS_CMAP(ras)) + IP_CMAP(ip) = RAS_CMAP(ras) + + # Round up to account for 16 bit line blocking. + w = RAS_WIDTH(ras) * (RAS_DEPTH(ras) / 8) + nchars = w + mod (w, SZB_CHAR) + + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Now process the image. + switch (RAS_DEPTH(ras)) { + case 1: + call eprintf ("Bitmap rasterfiles aren not supported.") + call flush (STDERR) + + case 8: + # Standard or byte encoded 8-bit rasterfile. + if (RAS_TYPE(ras) == RT_OLD || RAS_TYPE(ras) == RT_STANDARD) { + call ip_prband (ip, fd, IP_IM(ip), RAS_CMAP(ras)) + + } else if (RAS_TYPE(ras) == RT_BYTE_ENCODED) { + call ras_rle8 (ip, ras, fd, nchars) + + } else { + call eprintf ("Unsupported 8-bit RAS_TYPE: %d\n") + call pargi (RAS_TYPE(ras)) + call flush (STDERR) + } + + case 24, 32: + # 24 or 32-bit rasterfiles have no colormap (at least they + # shouldn't) and are pixel-interleaved. We already know how to + # do this so just call the right routines for processing. + + if (RAS_TYPE(ras) == RT_BYTE_ENCODED) { + call ip_fix_pixtype (ip) + call ras_rle24 (ip, ras, fd, nchars) + } else { + call ip_fix_pixtype (ip) + call ip_prpix (ip, fd, IP_IM(ip), NULL) + } + + default: + call eprintf ("Invalid pixel size.") + call flush (STDERR) + } + + # Clean up. + call ras_close (ras) + IP_CMAP(ip) = NULL +end + + +# IP_RAS_INFO - Print information about the raster file. + +procedure ip_ras_info (ip, ras, fname, verbose) + +pointer ip #i ip struct pointer +pointer ras #i ras struct pointer +char fname[ARB] #i file name +int verbose #i verbosity flag + +begin + # If not verbose print a one-liner. + if (verbose == NO) { +# call printf ("Input file:\n\t") + call printf ("%s: %20t%d x %d \t\t%d-bit Sun Rasterfile\n") + call pargstr (fname) + call pargi (RAS_WIDTH(ras)) + call pargi (RAS_HEIGHT(ras)) + call pargi (RAS_DEPTH(ras)) + + # Print out the format comment if any. +# if (IP_COMPTR(ip) != NULL) { +# if (COMMENT(ip) != '\0') { +# call printf ("%s\n") +# call pargstr (COMMENT(ip)) +# } +# call strcpy ("\0", COMMENT(ip), SZ_LINE) +# } +# if (RAS_DEPTH(ras) > 8) { +# if (RAS_TYPE(ras) != RT_FORMAT_RGB && RAS_TYPE(ras) != RT_OLD) { +# call eprintf ("\tNote: %d-bit rasterfile is stored as %s\n") +# call pargi (RAS_DEPTH(ras)) +# call pargstr ("ABGR and not ARGB") +# } +# } + return + } + + # Print a more verbose description. + call printf ("%s: %20tSun Rasterfile\n") + call pargstr (fname) + + # Print out the format comment if any. + if (IP_COMPTR(ip) != NULL) { + if (COMMENT(ip) != '\0') { + call printf ("%s\n") + call pargstr (COMMENT(ip)) + } + call strcpy ("\0", COMMENT(ip), SZ_LINE) + } + if (RAS_DEPTH(ras) > 8) { + if (RAS_TYPE(ras) != RT_FORMAT_RGB && RAS_TYPE(ras) != RT_OLD) { + call eprintf ("\tNote: %d-bit rasterfile is stored as %s\n") + call pargi (RAS_DEPTH(ras)) + call pargstr ("ABGR and not ARGB") + } + } + + call printf ("%20tByte Order:%38t%s\n") + if (IP_SWAP(ip) == S_NONE && BYTE_SWAP2 == NO ) + call pargstr ("Most Significant Byte First") + else + call pargstr ("Least Significant Byte First") + + call printf ("%20tResolution:%38t%d x %d\n") + call pargi (RAS_WIDTH(ras)) + call pargi (RAS_HEIGHT(ras)) + + call printf ("%20tType: %38t%d-bit %s %s\n") + call pargi (RAS_DEPTH(ras)) + switch (RAS_TYPE(ras)) { + case RT_OLD: + call pargstr ("Old") + case RT_STANDARD: + call pargstr ("Standard") + case RT_BYTE_ENCODED: + call pargstr ("Byte Encoded") + case RT_FORMAT_RGB: + call pargstr ("RGB") + case RT_FORMAT_TIFF: + call pargstr ("TIFF") + case RT_FORMAT_IFF: + call pargstr ("IFF") + default: + call pargstr ("Experimental (or unknown)") + } + if (RAS_MAPLENGTH(ras) > 0) + call pargstr ("Color Index") + else + call pargstr ("") + + if (RAS_MAPLENGTH(ras) > 0) { + call printf ("%20tColormap:%38t%d entries\n") + if (RAS_MAPTYPE(ras) == RMT_EQUAL_RGB) + call pargi (RAS_MAPLENGTH(ras)/3) + else + call pargi (RAS_MAPLENGTH(ras)) + } else + call printf ("%20tColormap:%38tnone\n") + + call printf ("%20tCompression: %38t%s\n") + if (RAS_TYPE(ras) == RT_BYTE_ENCODED) + call pargstr ("Run Length Encoded") + else + call pargstr ("None") + + call printf ("%20tAlpha Channel: %38t%s\n") + if (RAS_DEPTH(ras) == 32) + call pargstr ("yes") + else + call pargstr ("none") +end + + +# RAS_OPEN - Open the RAS structure descriptor. + +pointer procedure ras_open () + +pointer ras + +begin + iferr (call calloc (ras, SZ_RASHDR, TY_STRUCT)) + call error (0, "Error allocating RAS structure.") + RAS_CMAP(ras) = NULL + + return (ras) +end + + +# RAS_CLOSE - Close the RAS structure descriptor. + +procedure ras_close (ras) + +pointer ras #i RAS struct pointer + +begin + if (RAS_CMAP(ras) != NULL) + call mfree (RAS_CMAP(ras), TY_CHAR) + call mfree (ras, TY_STRUCT) +end + + +# RAS_RDCMAP - Read the colormap from the image if necessary. + +procedure ras_rdcmap (fd, ras, cmap) + +int fd #i file descriptor +pointer ras #i RAS struct pointer +pointer cmap #i colormap array ptr + +int ncolors + +long filepos +common /rascom/ filepos + +begin + # Now read the colormap, allocate the pointer if we need to. + ncolors = RAS_MAPLENGTH(ras) + if (RAS_MAPTYPE(ras) == RMT_EQUAL_RGB && ncolors > 0) { + if (cmap == NULL) + call calloc (cmap, ncolors*3, TY_CHAR) + call ip_agetb (fd, cmap, ncolors) + + } else if (RAS_MAPTYPE(ras) == RMT_RAW) { + call eprintf ("Warning: Can't handle RMT_RAW maptype - ignoring.\n") + call flush (STDERR) + + # Skip over the bytes anyway. + filepos = filepos + ncolors + call ip_lseek (fd, filepos) + return + } + + filepos = filepos + ncolors + call ip_lseek (fd, filepos) +end + + +# RAS_RLE8 - Process an 8-bit rasterfile into an IRAF image. This +# procedure handles both standard and RLE files. + +procedure ras_rle8 (ip, ras, fd, nchars) + +pointer ip #i ip struct pointer +pointer ras #i ras struct pointer +int fd #i input file descriptor +int nchars #i line size + +pointer im, data, op +int i, percent + +long filepos +common /rascom/ filepos + +begin + im = IP_IM(ip) + op = PTYPE(ip,1) + call malloc (data, nchars, TY_CHAR) + IO_DATA(op) = data + IO_NPIX(op) = RAS_WIDTH(ras) + + percent = 0 + do i = 1, RAS_HEIGHT(ras) { + call ras_read_rle (ras, fd, Memc[data], nchars) + + # Apply the colormap since this is just an index. + if (RAS_MAPLENGTH(ras) != 0 && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], RAS_WIDTH(ras), + RAS_CMAP(ras)) + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, RAS_WIDTH(ras), i) + + # Print percent done if being verbose + if (IP_VERBOSE(ip) == YES) { + if (i * 100 / RAS_HEIGHT(ras) >= percent + 10) { + percent = percent + 10 + call printf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDOUT) + } + } + + } + + if (IP_VERBOSE(ip) == YES) { + call printf (" Status: Done \n") + call flush (STDOUT) + } +end + + +# RAS_RLE24 - Process an 24-bit rasterfile into an IRAF image. This +# procedure handles both standard and RLE files. + +procedure ras_rle24 (ip, ras, fd, nchars) + +pointer ip #i ip struct pointer +pointer ras #i ras struct pointer +int fd #i input file descriptor +int nchars #i line size + +pointer im, data, op +int i, percent, npix + +long filepos +common /rascom/ filepos + +begin + im = IP_IM(ip) + op = PTYPE(ip,1) + call malloc (data, nchars, TY_SHORT) + IO_DATA(op) = data + IO_NPIX(op) = RAS_WIDTH(ras) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Allocate the pixtype data pointers. + npix = RAS_WIDTH(ras) + do i = 1, IP_NPIXT(ip) { + op = PTYPE(ip,i) + IO_NPIX(op) = npix + call calloc (IO_DATA(op), npix, TY_SHORT) + } + + percent = 0 + do i = 1, RAS_HEIGHT(ras) { + call ras_read_rle (ras, fd, Memc[data], nchars) + + # Separate pixels into different vectors. + call ip_upkpix (ip, data, npix) + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + if (IP_VERBOSE(ip) == YES) { + if (i * 100 / RAS_HEIGHT(ras) >= percent + 10) { + percent = percent + 10 + call printf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDOUT) + } + } + + } + if (IP_VERBOSE(ip) == YES) { + call printf (" Status: Done \n") + call flush (STDOUT) + } +end + + +# RAS_READ_RLE - Read a line of RLE encoded data from the file. + +procedure ras_read_rle (ras, fd, data, nchars) + +pointer ras #i ras struct pointer +int fd #i file descriptor +char data[ARB] #u output pixels +int nchars #i number of pixels to read + +int i +short pix, ras_rdbyte() + +long filepos +common /rascom/ filepos + +begin + i = 1 + while (i <= nchars) { + if (RAS_COUNT(ras) > 0) { + data[i] = RAS_CH(ras) + i = i + 1 + RAS_COUNT(ras) = RAS_COUNT(ras) - 1 + + } else { + pix = ras_rdbyte (fd) + if (pix == RAS_RLE) { + RAS_COUNT(ras) = ras_rdbyte (fd) + if (RAS_COUNT(ras) == 0) { + data[i] = pix + i = i + 1 + } else { + RAS_CH(ras) = ras_rdbyte (fd) + data[i] = RAS_CH(ras) + i = i + 1 + } + } else { + data[i] = pix + i = i + 1 + } + } + } +end + + +# RAS_RDBYTE - Read a single byte at the current offset from the file. + +short procedure ras_rdbyte (fd) + +int fd #i file descriptor + +short val +short ip_getb() + +long filepos +common /rascom/ filepos + +begin + iferr (val = ip_getb (fd, filepos)) + return (ERR) + + filepos = filepos + 1 + call ip_lseek (fd, filepos) + + return (val) +end diff --git a/pkg/dataio/import/bltins/ipxwd.x b/pkg/dataio/import/bltins/ipxwd.x new file mode 100644 index 00000000..62a48ff7 --- /dev/null +++ b/pkg/dataio/import/bltins/ipxwd.x @@ -0,0 +1,188 @@ +# IPXWD.X - Source file for the IMPORT task X Window Dump builtin format. + +include +include "../import.h" + + +# IP_XWD - Read and process an X Window Dump into an IRAF image. + +procedure ip_xwd (ip, fname, info_only, verbose) + +pointer ip #i import struct pointer +char fname[ARB] #i file name +int info_only #i print out image info only? +int verbose #i verbosity flag + +int fd +pointer im, cmap +int nchars +long depth, cmap_entries, hdr_size +long hskip, lpad, width,height + +long ip_getl() + +begin + # Get the input file descriptor and initialize the file position. + fd = IP_FD(ip) + im = IP_IM(ip) + call ip_lseek (fd, BOF) + + # Get some information from the header we'll need for processing. + hdr_size = ip_getl (fd, 1) + width = IP_AXLEN(ip,1) + height = IP_AXLEN(ip,2) + depth = ip_getl (fd, 45) + hskip = IP_HSKIP(ip) + lpad = IP_LPAD(ip) + cmap_entries = ip_getl (fd, 73) + nchars = width + lpad + + # See if we really want to convert this thing. + if (info_only == YES) { + call ip_xwd_info (ip, fname, depth, cmap_entries, verbose) + return + } + + # Now process the image. For 24-bit or 32-bit files we have an RGB + # image and can process normally, if this is an 8-bit image see if + # we have a colormap we need to use. + + if (depth > 8) { + call ip_prpix (ip, fd, im, NULL) + } else { + cmap = NULL + if (cmap_entries > 0) + call xwd_rdcmap (ip, fd, hdr_size, cmap_entries, cmap) + call ip_prband (ip, fd, im, cmap) + } + IP_CMAP(ip) = NULL +end + + +# IP_XWD_INFO - Print information about the xwd file. + +procedure ip_xwd_info (ip, fname, depth, ncolors, verbose) + +pointer ip #i ip struct pointer +char fname[ARB] #i file name +int depth #i bits per pixel +int ncolors #i number of colors +int verbose #i verbosity flag + +begin + # If not verbose print a one-liner. + if (verbose == NO) { + #call printf ("Input file:\n\t") + call printf ("%s: %20t%d x %d \t%d-bit X11 Window Dump\n") + call pargstr (fname) + call pargi (IP_AXLEN(ip,1)) + call pargi (IP_AXLEN(ip,2)) + call pargi (depth) + + # Print out the format comment if any. + if (IP_COMPTR(ip) != NULL) { + if (COMMENT(ip) != '\0') { + call printf ("%s\n") + call pargstr (COMMENT(ip)) + } + call strcpy ("\0", COMMENT(ip), SZ_LINE) + } + return + } + + # Print a more verbose description. + call printf ("%s: %20tX11 Window Dump\n") + call pargstr (fname) + + # Print out the format comment if any. + if (IP_COMPTR(ip) != NULL) { + if (COMMENT(ip) != '\0') { + call printf ("%s\n") + call pargstr (COMMENT(ip)) + } + call strcpy ("\0", COMMENT(ip), SZ_LINE) + } + + call printf ("%20tByte Order:%38t%s\n") + if (IP_SWAP(ip) == S_NONE && BYTE_SWAP2 == NO ) + call pargstr ("Most Significant Byte First") + else + call pargstr ("Least Significant Byte First") + + call printf ("%20tResolution:%38t%d x %d\n") + call pargi (IP_AXLEN(ip,1)) + call pargi (IP_AXLEN(ip,2)) + + call printf ("%20tType: %38t%d-bit %s\n") + call pargi (depth) + if (ncolors > 0) + call pargstr ("Color Index") + else + call pargstr ("") + + call printf ("%20tHeader size:%38t%d bytes\n") + call pargi (IP_HSKIP(ip)) + + if (ncolors > 0) { + call printf ("%20tColormap:%38t%d entries\n") + call pargi (ncolors) + } else + call printf ("%20tColormap:%38tnone\n") + + call printf ("%20tAlpha Channel: %38t%s\n") + if (depth == 32) + call pargstr ("8-bit") + else + call pargstr ("none") +end + + +# XWD_RDCMAP - Read colormap from an X11 Window Dump file and return a +# pointer to it. + +procedure xwd_rdcmap (ip, fd, hdr_size, ncolors, cmap) + +pointer ip #i task struct pointer +int fd #i file descriptor +int hdr_size #i header size +int ncolors #i number of colormap entries +pointer cmap #i colormap pointer + +int i +long filepos, pixel +int r, g, b +char flags, pad + +short ip_getb() +int ip_getu() +long ip_getl() + +define SZ_X11_CSTRUCT 12 + +begin + # Now read the colormap, allocate the pointer if we need to. + cmap = NULL + if (ncolors == 0) + return + else + call calloc (cmap, CMAP_SIZE*3, TY_CHAR) + + filepos = hdr_size + 3 + call ip_lseek (fd, filepos) + do i = 1, ncolors { + pixel = ip_getl (fd, filepos) + r = ip_getu (fd, filepos+4) + g = ip_getu (fd, filepos+6) + b = ip_getu (fd, filepos+8) + flags = ip_getb (fd, filepos+10) + pad = ip_getb (fd, filepos+11) + + CMAP(cmap,IP_RED,i) = r * 255 / 65535 + CMAP(cmap,IP_GREEN,i) = g * 255 / 65535 + CMAP(cmap,IP_BLUE,i) = b * 255 / 65535 + + filepos = filepos + SZ_X11_CSTRUCT + call ip_lseek (fd, filepos) + } + IP_CMAP(ip) = cmap +end diff --git a/pkg/dataio/import/bltins/mkpkg b/pkg/dataio/import/bltins/mkpkg new file mode 100644 index 00000000..88c4cadb --- /dev/null +++ b/pkg/dataio/import/bltins/mkpkg @@ -0,0 +1,13 @@ +# Mkpkg file for building the IMPORT task builtin formats. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + ipcmap.x ../import.h + ipgif.x ../import.h + ipras.x ../import.h + ipxwd.x ../import.h + ; diff --git a/pkg/dataio/import/fmtdb.x b/pkg/dataio/import/fmtdb.x new file mode 100644 index 00000000..8e5da296 --- /dev/null +++ b/pkg/dataio/import/fmtdb.x @@ -0,0 +1,610 @@ +include +include +include +include +include "import.h" + +define DEBUG false +define VDEBUG false + + +.help fmtdb Augl93 "Format Database Interface" +.ih +DESCRIPTION +Format Database Procedures -- Routines for opening the format database given +in the task parameter, reading sequential and randome records within it, as +well as getting entried from within a selected record. + +PROCEDURES +.nf + PUBLIC PROCEDURES: + + fd = fdb_opendb () + fdb_closedb (fd) + fmt = fdb_get_rec (fd, format) + fmt = fdb_next_rec (fd) + fmt = fdb_scan_records (fd, keyword, getop, opdata, fcn, fcndata) + fdbgstr (fmt, param, str, maxchar) + fdb_close (fmt) + + PRIVATE PROCEDURES: + + fdb_gfield (fd, fmt, key, val) + fdb_gexpr (fd, fmt, expr, maxchars) + fdb_strip_colon (in, out, maxch) + fdb_strip_quote (in, out, maxch) + +.fi + +The FDB_OPENDB procedure returns a file descriptor to the database file +(named in the task parameters), and FDB_CLOSEDB will close the file. When +searching for a specific format, the FDB_GET_REC procedure will return a +pointer to a symtab containing the database record. The FDB_NEXT_REC +will return a symtab pointer to the next record in the database when reading +it sequentially. The FDB_SCAN_RECS procedure can be used to scan the +database, returning the symtab pointer to a record whose 'keyword' field eval- +uates as true. The FDB_CLOSE procedure will free the symtab pointer returned +by the previous two routines. + +Once a pointer is found for a database record the FDBGSTR procedure +can be used to return a value for an entry within that database record. +.ih +SEE ALSO +Source code +.endhelp + + +# Symbol table definitions. +define LEN_INDEX 10 # Length of symtab index +define LEN_STAB (20*SZ_EXPR) # Length of symtab +define SZ_SBUF 512 # Size of symtab string buffer +define SYMLEN SZ_EXPR # Length of symbol structure +define SZ_FMTVAL SZ_EXPR # Size of format value string + +# Symbol table structure +define FMTVAL Memc[P2C($1)] # Format value string + + +# FDB_OPENDB -- Return a file descriptor to the format database. The +# specified database may be a list of files in which case they will be +# concatenated to a single temporary file that is removed when the database +# is closed. + +int procedure fdb_opendb () + +int fd, in, out +int stat, nfiles +pointer sp, fname, buf +pointer dbfiles + +int open() +int clpopni(), clplen(), clgfil() + +errchk open, clpopni + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + dbfiles = clpopni ("database") + nfiles = clplen (dbfiles) + if (nfiles == 0) { + call error (0, "No format database specified.") + + } else if (nfiles == 1) { + call clgstr ("database", Memc[fname], SZ_FNAME) + stat = clgfil (dbfiles, Memc[fname], SZ_FNAME) + + } else { + # The database parameter specified a list, concatenate the files + # to a temp file and open that instead. + call mktemp ("tmp$db", Memc[fname], SZ_FNAME) + out = open (Memc[fname], APPEND, TEXT_FILE) + while (clgfil (dbfiles, Memc[buf], SZ_FNAME) != EOF) { + in = open (Memc[buf], READ_ONLY, TEXT_FILE) + call fcopyo (in, out) + call close (in) + } + call close (out) + } + + # Open format database. + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + + call sfree (sp) + return (fd) +end + + +# FDB_CLOSEDB -- Close the format database. + +procedure fdb_closedb (fd) + +int fd #i file descriptor + +pointer sp, buf +int strncmp() + +begin + if (fd == NULL) + return + + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Get the database filename, if it's a temp file then the input + # was probably and list and we need to clean up. + call fstats (fd, F_FILENAME, Memc[buf], SZ_FNAME) + call close (fd) + if (strncmp (Memc[buf], "tmp$db", 6) == 0) + call delete (Memc[buf]) + + call sfree (sp) +end + + +# FDB_GET_REC -- Get the requested format information in symbol table. + +pointer procedure fdb_get_rec (fd, format) + +int fd #i database file descriptor +char format[ARB] #i format name + +pointer fmt #o format symbol table pointer +bool found +char colon +pointer sp, key, expr, sym + +int fscan(), stridx() +pointer stopen(), stenter() +bool streq() + +errchk stopen, stenter, fscan + +begin + # Allocate local storage. + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (expr, SZ_EXPR, TY_CHAR) + + # Find format entry. + found = false + colon = ':' + while (fscan (fd) != EOF) { + call fdb_gfield (fd, NULL, Memc[key], Memc[expr]) + if (stridx (colon, Memc[key]) > 0) { + call fdb_strip_colon (Memc[key], Memc[key], SZ_FNAME) + } else if (Memc[key]=='#') # skip comment lines + next + if (streq (Memc[key], format)) { + found = true + break + } + } + if (!found) { # check if entry was found + call sfree (sp) + return (NULL) + } + + # Create the symbol table. + fmt = stopen (format, LEN_INDEX, LEN_STAB, SZ_SBUF) + + # Read the file and enter the parameters in the symbol table. + sym = stenter (fmt, "format", SYMLEN) + call strcpy (format, FMTVAL(sym), SZ_FMTVAL) + while (fscan(fd) != EOF) { + call fdb_gfield (fd, fmt, Memc[key], Memc[expr]) + if (stridx (colon, Memc[key]) > 0) { + call fdb_strip_colon (Memc[key], Memc[expr], SZ_FNAME) + call strcpy ("alias", Memc[key], SZ_FNAME) + } else if (Memc[key] == '#' || Memc[key] == '') { + next + } else if (Memc[key] == EOS) { + call sfree (sp) + return (fmt) + } + sym = stenter (fmt, Memc[key], SYMLEN) + call strcpy (Memc[expr], FMTVAL(sym), SZ_FMTVAL) + } + + call close (fd) + call sfree (sp) + return (fmt) +end + + +# FDB_NEXT_REC -- Open format database and store the requested format +# information in symbol table. + +pointer procedure fdb_next_rec (fd) + +int fd #i input binary file descriptor + +pointer fmt # Format symbol table pointer +char colon +pointer sp, key, expr, sym, tmp + +int fscan(), stridx() +pointer stopen(), stenter() + +errchk stopen, stenter, fscan + +begin + # Allocate local storage. + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + call salloc (expr, SZ_FMTVAL, TY_CHAR) + + # Skip ahead top the beginning of the next record. + colon = ':' + while (fscan (fd) != EOF) { + Memc[key] = EOS + Memc[expr] = EOS + call fdb_gfield (fd, NULL, Memc[key], Memc[expr]) + if (stridx (colon, Memc[key]) > 0) { + call fdb_strip_colon (Memc[key], Memc[key], SZ_FNAME) + break + } else if (Memc[key] != '#' && Memc[key] != EOS) # skip comment + next + + } + + # The file will either be position at the BOF or at the end of the + # previous record. We will just read until the end of record and + # return the pointer. + + # Create symbol table, but strip the ':' first. + call fdb_strip_colon (Memc[key], Memc[tmp], SZ_FNAME) + fmt = stopen (Memc[tmp], LEN_INDEX, LEN_STAB, SZ_SBUF) + + if (DEBUG) {call eprintf("next_rec: fmt='%s' ");call pargstr(Memc[tmp])} + + # Read the file and enter the parameters in the symbol table. + sym = stenter (fmt, "format", SYMLEN) + call strcpy (Memc[tmp], FMTVAL(sym), SZ_FMTVAL) + while (fscan(fd) != EOF) { + call fdb_gfield (fd, fmt, Memc[key], Memc[expr]) + if (stridx (colon, Memc[key]) > 0) { + call fdb_strip_colon (Memc[key], Memc[expr], SZ_FNAME) + call strcpy ("alias", Memc[key], SZ_FNAME) + } else if (Memc[key] == '#' || Memc[key] == '') { + next + } else if (Memc[key] == EOS) { + call sfree (sp) + return (fmt) + } + sym = stenter (fmt, Memc[key], SYMLEN) + call strcpy (Memc[expr], FMTVAL(sym), SZ_FMTVAL) + } + + call sfree (sp) # shouldn't get here + return (NULL) +end + + +# FDB_SCAN_RECORDS -- Scan the database for a record whose image_id evaluates +# as true. + +pointer procedure fdb_scan_records (fd, keyword, getop, opdata, fcn, fcndata) + +int fd #i input binary file descriptor +char keyword[ARB] #i keyword to be evaluated +int getop #i func to get an operand +int opdata #i data pointer for getop +int fcn #i user functions in evvexpr +int fcndata #i data pointer for fcn + +pointer sp, expr, fm +pointer fmt, o + +pointer fdb_next_rec(), evvexpr() + +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + call salloc (fm, SZ_FNAME, TY_CHAR) + + # Rewind the file descriptor. + call seek (fd, BOF) + + if (DEBUG) { call eprintf("scan_rec: keyw='%s' ");call pargstr(keyword)} + + # Loop over all of the database records. + repeat { + fmt = fdb_next_rec (fd) + if (fmt == NULL) + break + call fdbgstr (fmt, keyword, Memc[expr], SZ_EXPR) + + if (DEBUG) { + call eprintf(" expr='%s'\n"); call pargstr(Memc[expr]) + call flush (STDERR) + } + + # Evaluate keyword expression. + iferr { + o = evvexpr (Memc[expr], getop, opdata, fcn, fcndata, EV_RNGCHK) + if (O_TYPE(o) != TY_BOOL) + call error (0, "Expression must be a boolean") + + } then { + call erract (EA_WARN) + break + } + + if (O_VALI(o) == YES) { # see if we've found it + if (DEBUG) { + call fdbgstr (fmt, "format", Memc[fm], SZ_FNAME) + call eprintf(" format='%s'\n");call pargstr(Memc[fm]) + } + call evvfree (o) + call sfree (sp) + return (fmt) + } + + call evvfree (o) + call fdb_close (fmt) # free fmt pointer + } + + call sfree (sp) + return (NULL) +end + + +# FDBCLOSE -- Close the format symbol table pointer. + +procedure fdb_close (fmt) + +pointer fmt #i Format symbol table pointer + +begin + if (fmt != NULL) + call stclose (fmt) +end + + +# FDBGSTR -- Get string valued format parameter. We simply return the +# expression, evaluation is up to the caller. + +procedure fdbgstr (fmt, param, str, maxchar) + +pointer fmt #i format symbol table pointer +char param[ARB] #i format parameter +char str[ARB] #o format parameter value +int maxchar #i maximum characters for string + +pointer sym, stfind() + +begin + call aclrc (str, maxchar) + sym = stfind (fmt, param) + if (sym == NULL) + call strcpy ("", str, maxchar) + else + call strcpy (FMTVAL(sym), str, maxchar) +end + + +## END OF PUBLIC PROCEDURES ## + + +# FDB_GFIELD - Get field in the database record. + +procedure fdb_gfield (fd, fmt, keyword, expr) + +int fd #i file descriptor +pointer fmt #i format symtab pointer +char keyword[ARB] #o field keyword +char expr[ARB] #o field expression + +pointer sp, tmp + +begin + call smark (sp) + call salloc (tmp, SZ_FNAME, TY_CHAR) + + call gargwrd (keyword, SZ_FNAME) + call gargwrd (Memc[tmp], SZ_FNAME) + + if (keyword[1] == EOS) { + call sfree (sp) + return + #} else if (Memc[tmp] == '#') { + } else if (keyword[1] == '#') { + expr[1] = EOS + } else if (Memc[tmp] != EOS) + call fdb_gexpr (fd, fmt, expr, SZ_EXPR) + else + expr[1] = EOS + + if (VDEBUG && keyword[1] != '#' && keyword[1] != '') { + call eprintf("'%s'='%s'\n") + call pargstr (keyword) ; call pargstr (expr) + } + + call sfree (sp) +end + + +# FDB_GEXPR - Get an expression from the input stream. + +procedure fdb_gexpr (fd, fmt, expr, maxchars) + +int fd #i file descriptor +pointer fmt #i format symtab pointer +char expr[ARB] #o returned expression +int maxchars #i maxchars + +pointer sp, ntok, tok, tokval, next_tok, last_tok +pointer sym +int level, qlevel + +int fscan() +pointer stfind() + +define dopar_ 99 + +begin + call smark (sp) + call salloc (tok, SZ_FNAME, TY_CHAR) + call salloc (ntok, SZ_FNAME, TY_CHAR) + + # Gather the expression. For now we'll just eat everything up until + # the closing parenthesis. + call aclrc (expr, maxchars) + + # An expression is made up of a numeric or symbolic constant, a + # quoted literal string, or some boolean or arithmetic operation. + # The strategy is to get the first token and take action depending + # on it's value and whether a following token completes the expr- + # ession. Expressions may break across newlines, literal strings + # must be enclosed in double quotes. + + level = 0 + qlevel = 0 + last_tok = TOK_UNKNOWN + repeat { + call gargtok (tokval, Memc[tok], SZ_EXPR) + + switch (tokval) { + case TOK_NUMBER: + call strcat (Memc[tok], expr, SZ_EXPR) + case TOK_STRING: + # There are no operations on strings, but they might be passed + # to a function as an argument, so check the level. Oh yeah, + # keep the double quotes in the string. + call strcat ("\"", expr, SZ_EXPR) + call strcat (Memc[tok], expr, SZ_EXPR) + call strcat ("\"", expr, SZ_EXPR) + case TOK_PUNCTUATION: + if (Memc[tok] == '(') + level = level + 1 + else if (Memc[tok] == ')') + level = level - 1 + call strcat (Memc[tok], expr, SZ_EXPR) + case TOK_OPERATOR: + if (Memc[tok] == '"') { # pass quoted strings + if (qlevel == 1) + qlevel = 0 + else if (qlevel == 0) + qlevel = 1 + } + if (Memc[tok] == '#' && qlevel == 0) { # skip comments + if (fscan (fd) == EOF) + call eprintf ("WARNING: Unexpected EOF\n") + if (level == 0 && last_tok != TOK_OPERATOR) + break + } else + call strcat (Memc[tok], expr, SZ_EXPR) + case TOK_NEWLINE: + if (level != 0 || last_tok == TOK_OPERATOR) { + if (fscan (fd) == EOF) + call eprintf ("WARNING: Unexpected EOF\n") + } + case TOK_IDENTIFIER: + if (Memc[tok] == '$') { + call strcat (Memc[tok], expr, SZ_EXPR) + } else if (fmt != NULL) { + sym = stfind (fmt, Memc[tok]) + if (sym == NULL) { + if (Memc[tok] == 'F') { + call strcat (Memc[tok], expr, SZ_EXPR) + } else { + call gargtok (next_tok, Memc[ntok], SZ_EXPR) + if (Memc[ntok] == '(') { + # Copy to output buffer, it's a function name. + call strcat (Memc[tok], expr, SZ_EXPR) + call strcat (Memc[ntok], expr, SZ_EXPR) + tokval = next_tok + level = level + 1 + next + } else { + # It's an undefined database field. + call eprintf("Undefined database field '%s'.\n") + call pargstr (Memc[tok]) + } + } + } else + call strcat (FMTVAL(sym), expr, SZ_EXPR) + } else { + call strcat (Memc[tok], expr, SZ_EXPR) + } + call gargtok (next_tok, Memc[tok], SZ_EXPR) +dopar_ if (Memc[tok] == '(') + level = level + 1 + else if (Memc[tok] == ')') { + level = level - 1 + if (level == 0) { + call strcat (Memc[tok], expr, SZ_EXPR) + break + } + } + if (next_tok != TOK_NEWLINE) + call strcat (Memc[tok], expr, SZ_EXPR) + tokval = next_tok + default: + break + } + + last_tok = tokval + } + + # Check for an obvious error. + if (level > 0) + call eprintf ("Missing right paren in expression: '%s'\n") + else if (level < 0) + call eprintf ("Missing left paren in expression: '%s'\n") + call pargstr (expr) + + call sfree (sp) +end + + +# FDB_STRIP_COLON -- Return the input string up to a ':' character. + +procedure fdb_strip_colon (in, out, maxch) + +char in[ARB] #i input string +char out[ARB] #o output string +int maxch #i max chars out + +int ip, op + +begin + op = 1 + do ip = 1, ARB { + if (in[ip] == ':' || op > maxch || in[ip] == EOS) + break + out[op] = in[ip] + op = op + 1 + } + out[op] = EOS +end + + +# FDB_STRIP_QUOTE -- Strip double quote chars from the string. + +procedure fdb_strip_quote (in, out, maxch) + +char in[ARB] #i input string +char out[ARB] #o output string +int maxch #i max chars out + +int ip, op + +begin + op = 1 + do ip = 1, ARB { + if (op > maxch || in[ip] == EOS) + break + if (in[ip] != '"') { + out[op] = in[ip] + op = op + 1 + } + } + out[op] = EOS +end diff --git a/pkg/dataio/import/generic/ipdb.x b/pkg/dataio/import/generic/ipdb.x new file mode 100644 index 00000000..4dfb81c7 --- /dev/null +++ b/pkg/dataio/import/generic/ipdb.x @@ -0,0 +1,813 @@ +include +include +include +include +include "../import.h" +include "../ipfcn.h" + +define DEBUG false + + +# IP_EVAL_DBREC -- For each of the keywords defined in the database record, +# evaluate the expression and load the task structure. + +procedure ip_eval_dbrec (ip) + +pointer ip #i task struct pointer + +int ival +pointer sp, dims, pixtype, err +pointer np, stp, sym + +pointer stname(), sthead(), stnext +int or(), ip_dbgeti() +bool streq() + +errchk ip_dbgeti() + +begin + call smark (sp) + call salloc (dims, SZ_EXPR, TY_CHAR) + call salloc (pixtype, SZ_EXPR, TY_CHAR) + call salloc (err, SZ_EXPR, TY_CHAR) + call aclrc (Memc[dims], SZ_EXPR) + call aclrc (Memc[pixtype], SZ_EXPR) + call aclrc (Memc[err], SZ_EXPR) + + # Load the defaults. + call ip_load_defaults (ip) + + # First thing we do is get the byte swap flag so the remaining + # fields will be interpreted correctly. + ifnoerr (ival = ip_dbgeti (ip, "bswap")) + IP_SWAP(ip) = ival + + # Next, we handle 'interleave', 'dims' and 'pixtype' as a special case + # since for band- and line-interleaved files we may need to fix up the + # pixtype pointers. + ifnoerr (ival = ip_dbgeti (ip, "interleave")) + IP_INTERLEAVE(ip) = ival + + ifnoerr (call ip_dbstr (ip, "dims", Memc[dims], SZ_EXPR)) + call ip_do_dims (ip, Memc[dims]) + + ifnoerr (call ip_dbstr (ip, "pixtype", Memc[pixtype], SZ_EXPR)) { + if (Memc[pixtype] == '"') + call fdb_strip_quote (Memc[pixtype], Memc[pixtype], SZ_EXPR) + call ip_do_pixtype (ip, Memc[pixtype]) + } + + # Loop over every symbol in the table. + stp = IP_FSYM(ip) + for (sym=sthead(stp); sym != NULL; sym=stnext(stp,sym)) { + np = stname (stp, sym) + + if (streq(Memc[np],"format") || # ignored or found already + streq(Memc[np],"alias") || + streq(Memc[np],"image_id") || + streq(Memc[np],"interleave") || + streq(Memc[np],"dims") || + streq(Memc[np],"pixtype") || + streq(Memc[np],"id_string") || + streq(Memc[np],"bswap")) { + next + } else if (streq(Memc[np],"hskip")) { + IP_HSKIP(ip) = ip_dbgeti (ip, "hskip") + } else if (streq(Memc[np],"tskip")) { + IP_TSKIP(ip) = ip_dbgeti (ip, "tskip") + } else if (streq(Memc[np],"bskip")) { + IP_BSKIP(ip) = ip_dbgeti (ip, "bskip") + } else if (streq(Memc[np],"lskip")) { + IP_LSKIP(ip) = ip_dbgeti (ip, "lskip") + } else if (streq(Memc[np],"lpad")) { + IP_LPAD(ip) = ip_dbgeti (ip, "lpad") + } else if (streq(Memc[np],"yflip")) { + if (ip_dbgeti (ip, "yflip") == YES) + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_Y) + } else if (streq(Memc[np],"error")) { + if (IP_OUTPUT(ip) != IP_INFO) + call ip_do_error (ip, Memc[P2C(sym)]) + } else if (streq(Memc[np],"comment")) { + call fdb_strip_quote (Memc[P2C(sym)], Memc[P2C(sym)], SZ_LINE) + call ip_do_comment (ip, Memc[P2C(sym)]) + } else { + call eprintf ("Warning: Unknown database keyword '%s'.\n") + call pargstr (Memc[np]) + } + } + + if (DEBUG) { call zzi_prstruct ("eval dbrec:", ip) } + call sfree (sp) +end + + +# IP_LOAD_DEFAULTS -- Load the default input parameters to the task structure. + +procedure ip_load_defaults (ip) + +pointer ip #i task struct pointer + +begin + IP_SWAP(ip) = DEF_SWAP # type of byte swapping + IP_INTERLEAVE(ip) = DEF_INTERLEAVE # type of data interleaving + IP_HSKIP(ip) = DEF_HSKIP # bytes to skip before data + IP_TSKIP(ip) = DEF_TSKIP # bytes to skip after data + IP_BSKIP(ip) = DEF_BSKIP # bytes between image bands + IP_LSKIP(ip) = DEF_LSKIP # bytes to skip at front of + IP_LPAD(ip) = DEF_LPAD # bytes to skip at end of + + # zero image dimensions + for (IP_NDIM(ip)=IM_MAXDIM; IP_NDIM(ip) > 0; IP_NDIM(ip)=IP_NDIM(ip)-1) + IP_AXLEN(ip,IP_NDIM(ip)) = 0 +end + + +# IP_DBFCN -- Called by evvexpr to execute format database special functions. + +procedure ip_dbfcn (ip, fcn, args, nargs, o) + +pointer ip #i task struct pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf, outstr +int fd, func, v_nargs +int i, len, nchar, ival, cur_offset, swap +char ch +short sval +real rval +double dval + +short ip_getb(), ip_gets() +int strdic(), ip_line(), ip_locate(), ip_getu() +int ctoi(), ctol(), ctor(), ctod(), ctocc(), ctowrd() +int and(), strlen(), clgeti() +long ip_getl() +real ip_getr(), ip_getn() +double ip_getd(), ip_getn8() +bool strne(), streq() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (outstr, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[outstr], SZ_LINE) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, DB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case CTOCC, CTOD, CTOI, CTOL, CTOR, CTOWRD: + v_nargs = -1 + + case GETSTR: + v_nargs = -1 + case GETB, GETU, GETI, GETI2, GETI4, GETR, GETR4, GETR8, + GETN, GETN4, GETN8: + v_nargs = 1 + + case LOCATE: + v_nargs = -1 + case LINE, SKIP: + v_nargs = 1 + + case BSWAP: + v_nargs = 1 + case PARAMETER, DEFAULT: + v_nargs = 1 + case SUBSTR: + v_nargs = 3 + case STRIDX: + v_nargs = 2 + case LSB_HOST, MSB_HOST: + v_nargs = 0 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + fd = IP_FD(ip) + swap = IP_SWAP(ip) + cur_offset = IP_OFFSET(ip) + + if (DEBUG) { + call eprintf ("cur_offset=%d nargs=%d func=%s swap=%d\n") + call pargi(cur_offset) ; call pargi(nargs) + call pargstr(fcn) ; call pargi (swap) + do i = 1, nargs + call zzi_pevop (args[i]) + call eprintf ("init op => ") ; call zzi_pevop(o) + + } + + # Evaluate the function. + switch (func) { + case CTOCC: # run the fmtio equivalents of the argument + if (nargs == 1) + ch = ip_getb (fd, O_VALI(args[1])) + else + ch = ip_getb (fd, cur_offset) + len = ctocc (ch, Memc[outstr], SZ_FNAME) + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call amovc (Memc[outstr], O_VALC(o), len) + cur_offset = cur_offset + 1 + call ip_lseek (fd, cur_offset) + + case CTOWRD: + if (nargs == 1) + call ip_gstr (fd, O_VALI(args[1]), SZ_FNAME, Memc[outstr]) + else + call ip_gstr (fd, cur_offset, SZ_FNAME, Memc[outstr]) + nchar = ctowrd (Memc[outstr], i, Memc[outstr], SZ_FNAME) + 1 + call ip_initop (o, nchar, TY_CHAR) + call aclrc (O_VALC(o), nchar) + call amovc (Memc[outstr], O_VALC(o), nchar) + cur_offset = cur_offset + nchar + 1 + call ip_lseek (fd, cur_offset) + + case CTOI: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctoi (Memc[outstr], i, ival) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctoi (Memc[outstr], i, ival) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_INT + + case CTOL: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctol (Memc[outstr], i, ival) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctol (Memc[outstr], i, ival) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_LONG + + case CTOR: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctor (Memc[outstr], i, rval) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctor (Memc[outstr], i, rval) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_REAL + + case CTOD: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctod (Memc[outstr], i, dval) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctod (Memc[outstr], i, dval) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_DOUBLE + + case GETSTR: + if (nargs == 1) { + call ip_gstr (fd, cur_offset, O_VALI(args[1]), Memc[outstr]) + cur_offset = cur_offset + O_VALI(args[1]) + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + cur_offset = O_VALI(args[1]) + O_VALI(args[2]) - 1 + } + if (strlen(Memc[outstr]) == 0) { + len = strlen ("ERR") + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call strcpy ("ERR", O_VALC(o), len-1) + } else { + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call amovc (Memc[outstr], O_VALC(o), len-1) + } + + case GETB: + if (nargs == 0) { + sval = ip_getb (fd, cur_offset) + cur_offset = cur_offset + SZB_CHAR + } else { + sval = ip_getb (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + SZB_CHAR + } + ival = sval + O_TYPE(o) = TY_INT + + case GETU: + if (nargs == 0) { + sval = short (ip_getu (fd, cur_offset)) + cur_offset = cur_offset + (SZB_CHAR * SZ_SHORT) + } else { + sval = short (ip_getu (fd, O_VALI(args[1]))) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_SHORT) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) + call bswap2 (sval, 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + ival = sval + O_TYPE(o) = TY_INT + + case GETI, GETI2: + if (nargs == 0) { + sval = ip_gets (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_SHORT) + } else { + sval = ip_gets (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_SHORT) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) + call bswap2 (sval, 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + ival = sval + O_TYPE(o) = TY_INT + + case GETI4: + if (nargs == 0) { + ival = ip_getl (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_LONG) + } else { + ival = ip_getl (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_LONG) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) + call bswap4 (ival, 1, ival, 1, (SZ_INT32*SZB_CHAR)) + O_TYPE(o) = TY_INT + + case GETR, GETR4: + if (nargs == 0) { + rval = ip_getr (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_REAL) + } else { + rval = ip_getr (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_REAL) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap4 (rval, 1, rval, 1, (SZ_REAL*SZB_CHAR)) + O_TYPE(o) = TY_REAL + + case GETR8: + if (nargs == 0) { + dval = ip_getd (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_DOUBLE) + } else { + dval = ip_getd (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_DOUBLE) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap8 (dval, 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + O_TYPE(o) = TY_DOUBLE + + case GETN, GETN4: + if (nargs == 0) { + rval = ip_getn (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_REAL) + } else { + rval = ip_getn (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_REAL) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap4 (rval, 1, rval, 1, (SZ_REAL*SZB_CHAR)) + O_TYPE(o) = TY_REAL + + case GETN8: + if (nargs == 0) { + dval = ip_getn8 (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_DOUBLE) + } else { + dval = ip_getn8 (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_DOUBLE) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap8 (dval, 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + O_TYPE(o) = TY_DOUBLE + + case LOCATE: # locate the pattern in the file + if (nargs == 1) + ival = ip_locate (fd, cur_offset, O_VALC(args[1])) + else if (nargs == 2) + ival = ip_locate (fd, O_VALI(args[1]), O_VALC(args[2])) + if (ival == ERR) + ival = 1 + O_TYPE(o) = TY_INT + cur_offset = ival + + case LINE: # locate the line no. in the file + ival = ip_line (fd, O_VALI(args[1])) + if (ival == ERR) + ival = 1 + O_TYPE(o) = TY_INT + cur_offset = ival + + case SKIP: # skip a certain number of bytes + ival = O_VALI(args[1]) + O_TYPE(o) = TY_INT + cur_offset = cur_offset + ival + + case BSWAP: # byte-swap argument + O_TYPE(o) = O_TYPE(args[1]) + switch (O_TYPE(args[1])) { + case TY_SHORT: + call bswap2 (O_VALS(args[1]), 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + case TY_INT: + call bswap4 (O_VALI(args[1]), 1, ival, 1, (SZ_INT32*SZB_CHAR)) + case TY_LONG: + call bswap4 (O_VALL(args[1]), 1, ival, 1, (SZ_LONG*SZB_CHAR)) + case TY_REAL: + call bswap4 (O_VALR(args[1]), 1, rval, 1, (SZ_REAL*SZB_CHAR)) + case TY_DOUBLE: + call bswap8 (O_VALD(args[1]), 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + } + + case PARAMETER: # return current task parameter value + if (streq(O_VALC(args[1]),"dims")) { + call clgstr ("dims", Memc[outstr], SZ_FNAME) + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call strcpy (Memc[outstr], O_VALC(o), len) + } else if (streq(O_VALC(args[1]),"pixtype")) { + call clgstr ("pixtype", Memc[outstr], SZ_FNAME) + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call strcpy (Memc[outstr], O_VALC(o), len) + } else if (streq(O_VALC(args[1]),"interleave")) { + ival = clgeti ("interleave") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bswap")) { + call clgstr ("bswap", Memc[outstr], SZ_FNAME) + if (strne("no",Memc[outstr]) && strne("none",Memc[outstr])) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + } else if (streq(O_VALC(args[1]),"hskip")) { + ival = clgeti ("hskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"tskip")) { + ival = clgeti ("tskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bskip")) { + ival = clgeti ("bskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lskip")) { + ival = clgeti ("lskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lpad")) { + ival = clgeti ("lpad") + O_TYPE(o) = TY_INT + } + + case DEFAULT: # return default task parameter value + if (streq(O_VALC(args[1]),"dims")) { + call ip_initop (o, 1, TY_CHAR) + call strcpy ("", O_VALC(o), 1) + } else if (streq(O_VALC(args[1]),"pixtype")) { + call ip_initop (o, 1, TY_CHAR) + call strcpy ("", O_VALC(o), 1) + } else if (streq(O_VALC(args[1]),"interleave")) { + ival = DEF_INTERLEAVE + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bswap")) { + ival = DEF_SWAP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"hskip")) { + ival = DEF_HSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"tskip")) { + ival = DEF_TSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bskip")) { + ival = DEF_BSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lskip")) { + ival = DEF_LSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lpad")) { + ival = DEF_LPAD + O_TYPE(o) = TY_INT + } + + case LSB_HOST: # host is an LSB byte ordered machine + if (BYTE_SWAP2 == YES) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + + case MSB_HOST: # host is an MSB byte ordered machine + if (BYTE_SWAP2 == NO) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + + case SUBSTR: # return a substring of the argument + + case STRIDX: # return offset of a char w/in str + + } + + # Write result to output operand. + O_LEN(o) = 0 + switch (O_TYPE(o)) { + case TY_USHORT, TY_SHORT: + O_VALS(o) = sval + case TY_INT, TY_BOOL: + O_VALI(o) = ival + case TY_LONG: + O_VALL(o) = ival + case TY_REAL: + O_VALR(o) = rval + case TY_DOUBLE: + O_VALD(o) = dval + } + + if (DEBUG) { call eprintf("ip_dbfcn: ") ; call zzi_pevop (o) } + + IP_OFFSET(ip) = cur_offset + call sfree (sp) +end + + +# IP_DBSTR -- Get a string valued expression from the database. + +procedure ip_dbstr (ip, param, outstr, maxch) + +pointer ip #i task struct pointer +char param[ARB] #i parameter to evaluate +char outstr[ARB] #o result string +int maxch #i max length of string + +pointer sp, expr, o + +int locpr(), strlen() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + call aclrc (Memc[expr], SZ_EXPR) + + # Get the requested parameter. + call aclrc (outstr, SZ_EXPR) + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "FDBGET: Format parameter not found") + + if (DEBUG) { + call eprintf("ip_dbstr: expr='%s' len=%d ");call pargstr(Memc[expr]) + call pargi(strlen(Memc[expr])) + } + + # Evaluate the expression. + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) != TY_CHAR) + call error (0, "ip_dbstr: Expression must be a string valued") + else + call amovc (O_VALC(o), outstr, (min(strlen(O_VALC(o)),maxch))) + } then + call erract (EA_WARN) + + if (DEBUG) { call eprintf ("outstr=:%s:\n") ; call pargstr (outstr) } + + call evvfree (o) + call sfree (sp) +end + + + +# IP_DBGETI -- Get integer valued format parameter from the database. + +int procedure ip_dbgeti (ip, param) + +pointer ip #i task struct pointer +char param[ARB] #i requested parameter + +int val +pointer sp, expr, o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + + # Get the requested parameter. + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "IP_DBGET: Format parameter not found") + + # Evaluate the expression. + if (DEBUG) { + call eprintf ("ip_dbget: expr='%s'\n") + call pargstr (Memc[expr]) + call flush (STDERR) + } + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) == TY_BOOL) { + val = O_VALI(o) + } else if (O_TYPE(o) != TY_INT && O_TYPE(o) != TY_SHORT) { + call error (0, "Expression must be an integer") + } else + val = O_VALI(o) + + if (DEBUG) { + call eprintf ("ip_dbget: val=%d type=%d ecpr=:%s:\n") + call pargi (val) + call pargi (O_TYPE(o)) + call pargstr (Memc[expr]) + call flush (STDERR) + } + } then + call erract (EA_WARN) + + call evvfree (o) + call sfree (sp) + return (val) +end + + +# IP_DBGETR -- Get real valued format parameter from the database. + +real procedure ip_dbgetr (ip, param) + +pointer ip #i task struct pointer +char param[ARB] #i requested parameter + +real val +pointer sp, expr, o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + + # Get the requested parameter. + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "IP_DBGET: Format parameter not found") + + # Evaluate the expression. + if (DEBUG) { + call eprintf ("ip_dbget: expr='%s'\n") + call pargstr (Memc[expr]) + call flush (STDERR) + } + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) == TY_BOOL) { + val = O_VALI(o) + } else if (O_TYPE(o) != TY_REAL) { + call error (0, "Expression must be a real") + } else + val = O_VALR(o) + + if (DEBUG) { + call eprintf ("ip_dbget: val=%d type=%d ecpr=:%s:\n") + call pargr (val) + call pargi (O_TYPE(o)) + call pargstr (Memc[expr]) + call flush (STDERR) + } + } then + call erract (EA_WARN) + + call evvfree (o) + call sfree (sp) + return (val) +end + + +# IP_DO_ERROR -- Process the error parameter. + +procedure ip_do_error (ip, expr) + +pointer ip #i task struct pointer +char expr[ARB] #i error string + +pointer o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +bool strne() +errchk evvexpr + +begin + if (DEBUG) {call eprintf ("error expr: '%s' ") ; call pargstr (expr)} + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ip_getop), ip, locpr(ip_dbfcn), ip, + EV_RNGCHK) + + if (DEBUG) { call eprintf("-> '%s'\n") ; call pargstr(O_VALC(o)) } + + if (O_TYPE(o) != TY_CHAR) + call error (2, "do_error: Expression must be a string valued") + else { + if (strne("okay",O_VALC(o))) + call error (2, O_VALC(o)) + } + call evvfree (o) + + } then + if (IP_OUTPUT(ip) != IP_INFO) + call erract (EA_FATAL) +end + + +# IP_DO_COMMENT - Process a comment line in the format database. + +procedure ip_do_comment (ip, comstr) + +pointer ip #i task struct pointer +char comstr[ARB] #i comment to add + +pointer sp, buf + +begin + # Copy the comment line to the comment block. + if (IP_COMPTR(ip) == NULL) + call calloc (IP_COMPTR(ip), SZ_COMMENT, TY_CHAR) + + if (COMMENT(ip) == '\0') { + call strcpy ("\t", COMMENT(ip), SZ_LINE) + call strcat (comstr, COMMENT(ip), SZ_LINE) + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + Memc[buf] = '\0' + call strcpy ("\t", Memc[buf], SZ_LINE) + call strcat (comstr, Memc[buf], SZ_LINE) + call strcat ("\n", Memc[buf], SZ_LINE) + call strcat (COMMENT(ip), Memc[buf], SZ_COMMENT) + + call strcpy (Memc[buf], COMMENT(ip), SZ_COMMENT) + + call sfree (sp) + } +end + + +# IP_INITOP - Initialize an operand pointer to the requested values + +procedure ip_initop (o, len, type) + +pointer o #u operand pointer +int len #i length of array +int type #i data type of operand + +begin + O_LEN(o) = len + O_TYPE(o) = type + if (len > 1) + call calloc (O_VALP(o), len, type) +end diff --git a/pkg/dataio/import/generic/ipfio.x b/pkg/dataio/import/generic/ipfio.x new file mode 100644 index 00000000..2977d8cb --- /dev/null +++ b/pkg/dataio/import/generic/ipfio.x @@ -0,0 +1,569 @@ +include +include +include "../import.h" + +define DEBUG false + + +# IP_GSTR -- Get a string of the specifed length from the given offset. + +procedure ip_gstr (fd, offset, len, outstr) + +int fd +int offset +int len +char outstr[ARB] + +int nstat, read() +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, len+2, TY_CHAR) + call aclrc (Memc[buf], len+2) + call aclrc (outstr, len+2) + + call ip_lseek (fd, offset) + nstat = read (fd, Memc[buf], len) + + if (mod(offset,2) == 0 && offset > 1) + call bytmov (Memc[buf], 2, Memc[buf], 1, len) + call chrupk (Memc[buf], 1, outstr, 1, len) + + if (DEBUG) { call eprintf ("ip_gstr: :%s: len=%d\n"); + call pargstr(outstr) ; call pargi (len) } + call sfree (sp) +end + + +# IP_GETB -- Get a byte from the given offset. + +short procedure ip_getb (fd, offset) + +int fd +int offset + +int nstat, read() +short val +char buf[2] + +begin + call ip_lseek (fd, offset) + nstat = read (fd, buf, 2) + + if (mod(offset,2) == 0) + call bytmov (buf, 2, buf, 1, 2) + call chrupk (buf, 1, buf, 1, 2) + + if (DEBUG) { call eprintf ("ip_getb: %d\n"); call pargs(buf[1]) } + if (buf[1] < 0) + val = buf[1] + 256 + else + val = buf[1] + return (val) +end + + +# IP_GETU -- Get a unsigned short integer from the given offset. + +int procedure ip_getu (fd, offset) + +int fd +int offset + +int val +short ip_gets() + +begin + val = ip_gets (fd, offset) + if (val < 0) + val = val + 65536 + return (val) +end + +# IP_GET[silrd] -- Get a value of from the given offset. + + + +short procedure ip_gets (fd, offset) + +int fd +int offset + +int nstat, read() +short val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_SHORT * SZB_CHAR) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargs(val) } + return (val) +end + + +int procedure ip_geti (fd, offset) + +int fd +int offset + +int nstat, read() +int val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_INT32 * SZB_CHAR) + if (SZ_INT != SZ_INT32) + call iupk32 (val, val, 1) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargi(val) } + return (val) +end + + +long procedure ip_getl (fd, offset) + +int fd +int offset + +int nstat, read() +long val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_INT32 * SZB_CHAR) + if (SZ_INT != SZ_INT32) + call iupk32 (val, val, 1) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargl(val) } + return (val) +end + + +real procedure ip_getr (fd, offset) + +int fd +int offset + +int nstat, read() +real val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_REAL * SZB_CHAR) + call ieeupkr (val) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargr(val) } + return (val) +end + + +double procedure ip_getd (fd, offset) + +int fd +int offset + +int nstat, read() +double val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_DOUBLE * SZB_CHAR) + call ieeupkd (val) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargd(val) } + return (val) +end + + +# IP_GETN -- Get a native floating point number from the given offset. + +real procedure ip_getn (fd, offset) + +int fd +int offset + +int nstat, read() +real rval + +begin + call ip_lseek (fd, offset) + nstat = read (fd, rval, SZ_REAL) + + if (DEBUG) { call eprintf ("ip_getn: %g\n"); call pargr(rval) } + return (rval) +end + + +# IP_GETN8 -- Get a native double precision floating point number from the +# given offset. + +double procedure ip_getn8 (fd, offset) + +int fd +int offset + +int nstat, read() +double dval + +begin + call ip_lseek (fd, offset) + nstat = read (fd, dval, SZ_DOUBLE) + + if (DEBUG) { call eprintf ("ip_getn8: %g\n"); call pargd(dval) } + return (dval) +end + + +# IP_AGETB -- Get an array of bytes from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetb (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +pointer sp, buf +int fp, nval, nstat +int ip_lnote(), read() + +begin + fp = ip_lnote(fd) + if (mod(fp,2) == 0 && fp != 1) + nval = len + else + nval = len + 1 + + call smark (sp) + call salloc (buf, nval, TY_CHAR) + + if (ptr == NULL) + call malloc (ptr, nval * SZB_CHAR, TY_CHAR) + nstat = read (fd, Memc[buf], nval / SZB_CHAR + 1) + + fp = ip_lnote(fd) + if (mod(fp,2) == 0 && fp != 1) + call bytmov (Memc[buf], 2, Memc[buf], 1, nval) + call achtbc (Memc[buf], Memc[ptr], len) + + call sfree (sp) +end + + +# IP_AGETU -- Get an array of from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetu (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +begin + call ip_agets (fd, ptr, len) + call achtsu (Mems[ptr], Mems[ptr], len) +end + + +# IP_AGET[silrd] -- Get an array of from the file. The data pointer is +# allocated if necessary and contains the data on output. + + +procedure ip_agets (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_SHORT) + nstat = read (fd, Mems[ptr], len * SZ_SHORT) +end + + +procedure ip_ageti (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_INT) + nstat = read (fd, Memi[ptr], len * SZ_INT32) + if (SZ_INT != SZ_INT32) + call iupk32 (Memi[ptr], Memi[ptr], len) +end + + +procedure ip_agetl (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_LONG) + nstat = read (fd, Meml[ptr], len * SZ_INT32) + if (SZ_INT != SZ_INT32) + call iupk32 (Meml[ptr], Meml[ptr], len) +end + + +procedure ip_agetr (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_REAL) + nstat = read (fd, Memr[ptr], len * SZ_REAL) + call ieevupkr (Memr[ptr], Memr[ptr], len) +end + + +procedure ip_agetd (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_DOUBLE) + nstat = read (fd, Memd[ptr], len * SZ_DOUBLE) + call ieevupkd (Memd[ptr], Memd[ptr], len) +end + + + +# IP_AGETN -- Get an array of native floats from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetn (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_REAL) + nstat = read (fd, Memr[ptr], len * SZ_REAL) +end + + +# IP_AGETN8 -- Get an array of native doubles from the file. The data pointer +# is allocated if necessary and contains the data on output. + +procedure ip_agetn8 (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_DOUBLE) + nstat = read (fd, Memd[ptr], len * SZ_DOUBLE) +end + + +# ----------------------------------------------------------------- +# ------------------ UTILITY FILE I/O FUNCTIONS ------------------- +# ----------------------------------------------------------------- + + +define BLKSIZE 1024 + +# IP_LINE -- Return the offset of the start of the given line number. + +int procedure ip_line (fd, line) + +int fd #i input file descriptor +int line #i line number to search + +pointer sp, cbuf, buf +int nl, offset, i, nread, fsize + +int read(), fstati() + +define done_ 99 +define err_ 98 + +begin + if (line == 1) { + return (1) + } else { + call smark (sp) + call salloc (buf, BLKSIZE, TY_CHAR) + call salloc (cbuf, BLKSIZE, TY_CHAR) + + # Rewind file descriptor + call ip_lseek (fd, BOF) + nl = 1 + offset = 1 + + nread = BLKSIZE / SZB_CHAR + fsize = fstati (fd, F_FILESIZE) + while (read (fd, Memc[buf], nread) != EOF) { + # Convert it to spp chars. + call ip_lskip (fd, nread) + call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE) + do i = 1, BLKSIZE { + if (Memc[cbuf+i-1] == '\n') { + nl = nl + 1 + offset = offset + 1 + if (nl == line) + goto done_ + } else + offset = offset + 1 + if (offset >= fsize) + goto err_ + } + } +err_ call sfree (sp) + call ip_lseek (fd, BOF) + return (ERR) + +done_ if (DEBUG) { call eprintf("ip_line: '%s'\n"); call pargi(offset) } + call sfree (sp) + call ip_lseek (fd, offset) + return (offset) + } +end + + +# IP_LOCATE -- Return the offset of the start of the given pattern. + +int procedure ip_locate (fd, offset, pattern) + +int fd #i input file descriptor +int offset #i offset to begin search +char pattern[ARB] #i pattern to locate + +pointer sp, cbuf, buf +int fsize, nread, patlen, cur_offset, loc + +int fstati(), read(), strsearch(), strlen() + +define done_ 99 + +begin + # Rewind file descriptor + call ip_lseek (fd, offset) + cur_offset = offset + + call smark (sp) + call salloc (buf, BLKSIZE, TY_CHAR) + call salloc (cbuf, BLKSIZE, TY_CHAR) + + if (DEBUG) { call eprintf("ip_loc: offset %d\n"); call pargi(offset)} + + nread = BLKSIZE / SZB_CHAR + fsize = fstati (fd, F_FILESIZE) + patlen = strlen (pattern) + while (read (fd, Memc[buf], nread) != EOF) { + # Convert it to spp chars. + call ip_lskip (fd, nread) + call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE) + loc = strsearch (Memc[cbuf], pattern) + if (loc != 0) { + cur_offset = cur_offset + loc - 1 - patlen + goto done_ + } else { + # Allow some overlap in case the pattern broke over the blocks. + cur_offset = cur_offset + BLKSIZE - 2 * patlen + call ip_lseek (fd, cur_offset) + if (cur_offset + BLKSIZE > fsize) + nread = fsize - cur_offset + 1 + } + } + call sfree (sp) + call ip_lseek (fd, BOF) + return (ERR) + +done_ if (DEBUG) { call eprintf("ip_loc: %d\n"); call pargi(cur_offset)} + call sfree (sp) + call ip_lseek (fd, offset) + return (cur_offset) +end + + +# IP_LSEEK -- Set the file position as a byte offset. + +procedure ip_lseek (fd, offset) + +int fd #i file descriptor +int offset #i requested offset + +long cur_offset, where, fsize +int fstati() +common /fiocom/ cur_offset + +begin + if (offset == BOF || offset == ERR) { + cur_offset = 1 + call seek (fd, BOF) + } else { + fsize = fstati (fd, F_FILESIZE) * SZB_CHAR + cur_offset = min (fsize, offset) + where = min (fsize, (offset/SZB_CHAR+mod(offset,2))) + call seek (fd, where) + } +end + + +# IP_LNOTE -- Note the file position as a byte offset. + +int procedure ip_lnote (fd) + +int fd #i file descriptor (unused) + +long cur_offset +common /fiocom/ cur_offset + +begin + return (cur_offset) +end + + +# IP_LSKIP -- Bump the file position by a byte offset. + +procedure ip_lskip (fd, skip) + +int fd #i file descriptor +int skip + +long cur_offset +common /fiocom/ cur_offset + +begin + call ip_lseek (fd, cur_offset+skip) +end diff --git a/pkg/dataio/import/generic/ipobands.x b/pkg/dataio/import/generic/ipobands.x new file mode 100644 index 00000000..65c6c1c4 --- /dev/null +++ b/pkg/dataio/import/generic/ipobands.x @@ -0,0 +1,375 @@ +include +include +include +include +include "../import.h" +include "../ipfcn.h" + +define DEBUG false +define VDEBUG false + + +# IP_GETOP -- Called by evvexpr to get an operand. + +procedure ip_getop (ip, opname, o) + +pointer ip #i task struct pointer +char opname[ARB] #i operand name to retrieve +pointer o #o output operand pointer + +int i, nops, found, optype +pointer sp, buf +pointer op + +int fstati(), ip_ptype(), strlen(), strncmp() +bool streq() + +begin + # First see if it's one of the special file operands. + if (opname[1] == '$') { + if (strncmp(opname, "$FSIZE", 3) == 0) { + O_LEN(o) = 0 + O_TYPE(o) = TY_INT + O_VALI(o) = fstati (IP_FD(ip), F_FILESIZE) * SZB_CHAR + } else if (strncmp(opname, "$FNAME", 3) == 0) { + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + call fstats (IP_FD(ip), F_FILENAME, Memc[buf], SZ_FNAME) + + O_TYPE(o) = TY_CHAR + O_LEN(o) = strlen (Memc[buf]) + 1 + call malloc (O_VALP(o), O_LEN(o), TY_CHAR) + call strcpy (Memc[buf], O_VALC(o), i) + call sfree (sp) + } + + return + } + + nops = IP_NPIXT(ip) + found = NO + do i = 1, nops { + # Search for operand name which matches requested value. + op = PTYPE(ip,i) + if (streq (Memc[IO_TAG(op)],opname)) { + found = YES + break + } + } + + if (VDEBUG) { + call eprintf ("getop: opname=%s tag=%s found=%d ") + call pargstr(opname) ; call pargstr(Memc[IO_TAG(op)]) + call pargi(found) + if (found == YES) call zzi_prop (op) + } + + if (found == YES) { + # Copy operand descriptor to 'o' + optype = ip_ptype (IO_TYPE(op), IO_NBYTES(op)) + switch (optype) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), IO_NPIX(op), TY_SHORT) + call amovs (Mems[IO_DATA(op)], Mems[O_VALP(o)], IO_NPIX(op)) + + case TY_INT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_INT + call malloc (O_VALP(o), IO_NPIX(op), TY_INT) + call amovi (Memi[IO_DATA(op)], Memi[O_VALP(o)], IO_NPIX(op)) + + case TY_LONG: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_LONG + call malloc (O_VALP(o), IO_NPIX(op), TY_LONG) + call amovl (Meml[IO_DATA(op)], Meml[O_VALP(o)], IO_NPIX(op)) + + case TY_REAL: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), IO_NPIX(op), TY_REAL) + call amovr (Memr[IO_DATA(op)], Memr[O_VALP(o)], IO_NPIX(op)) + + case TY_DOUBLE: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_DOUBLE + call malloc (O_VALP(o), IO_NPIX(op), TY_DOUBLE) + call amovd (Memd[IO_DATA(op)], Memd[O_VALP(o)], IO_NPIX(op)) + + } + + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call sprintf (Memc[buf], SZ_LINE, "Unknown outbands operand `%s'\n") + call pargstr(opname) + call sfree (sp) + call error (1, Memc[buf]) + } +end + + +# IP_EVALUATE -- Evaluate the outbands expression. + +pointer procedure ip_evaluate (ip, expr) + +pointer ip #i task struct pointer +char expr[ARB] #i expression to be evaluated + +pointer o # operand pointer to result + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_obfcn() +errchk evvexpr + +begin + if (DEBUG) { call eprintf("ip_eval: expr='%s'\n") ; call pargstr(expr) } + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ip_getop), ip, locpr(ip_obfcn), ip, + EV_RNGCHK) + } then + call erract (EA_FATAL) + + return (o) +end + + +# IP_OBFCN -- Called by evvexpr to execute import outbands special functions. + +procedure ip_obfcn (ip, fcn, args, nargs, o) + +pointer ip #i task struct pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf +pointer r, g, b, gray, color, cmap +int i, len, v_nargs, func + +int or(), strdic() +bool strne() + +define setop_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, OB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case GRAY, GREY: + v_nargs = 3 + case FLIPX, FLIPY: + v_nargs = 1 + case RED, GREEN, BLUE: + v_nargs = 1 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + if (DEBUG) { + call eprintf ("obfcn: nargs=%d func=%d\n") + call pargi (nargs) ; call pargi (func) + do i = 1, nargs { call eprintf ("\t") ; call zzi_pevop (args[i]) } + call flush (STDERR) + } + + # Evaluate the function. + switch (func) { + case GRAY, GREY: + # evaluate expression for NTSC grayscale. + r = O_VALP(args[1]) + g = O_VALP(args[2]) + b = O_VALP(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + gray = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mems[r+i] + + G_COEFF * Mems[g+i] + + B_COEFF * Mems[b+i] + } + + case TY_INT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memi[r+i] + + G_COEFF * Memi[g+i] + + B_COEFF * Memi[b+i] + } + + case TY_LONG: + do i = 0, len { + Memr[gray+i] = R_COEFF * Meml[r+i] + + G_COEFF * Meml[g+i] + + B_COEFF * Meml[b+i] + } + + case TY_REAL: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memr[r+i] + + G_COEFF * Memr[g+i] + + B_COEFF * Memr[b+i] + } + + case TY_DOUBLE: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memd[r+i] + + G_COEFF * Memd[g+i] + + B_COEFF * Memd[b+i] + } + + } + + case RED: + # Get the red colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + r = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Mems[r+i]+1) + + case TY_INT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Memi[r+i]+1) + + case TY_LONG: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Meml[r+i]+1) + + } + + case GREEN: + # Get the blue colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + g = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,Mems[g+i]+1) + + case TY_INT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,char(Memi[g+i]+1)) + + case TY_LONG: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,char(Meml[g+i]+1)) + + } + + case BLUE: + # Get the blue colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + b = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,Mems[b+i]+1) + + case TY_INT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,char(Memi[b+i]+1)) + + case TY_LONG: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,char(Meml[b+i]+1)) + + } + + case FLIPX: + # Set flag to reverse pixel order on output. + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_X) + goto setop_ + + case FLIPY: + # Set flag to write image from bottom to top. + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_Y) + + # Copy argument operand descriptor to 'o' +setop_ switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), O_LEN(args[1]), TY_SHORT) + call amovs (Mems[O_VALP(ARGS[1])], Mems[O_VALP(o)], O_LEN(o)) + + case TY_INT: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_INT + call malloc (O_VALP(o), O_LEN(args[1]), TY_INT) + call amovi (Memi[O_VALP(args[1])], Memi[O_VALP(o)], O_LEN(o)) + + case TY_LONG: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_LONG + call malloc (O_VALP(o), O_LEN(args[1]), TY_LONG) + call amovl (Meml[O_VALP(args[1])], Meml[O_VALP(o)], O_LEN(o)) + + case TY_REAL: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), O_LEN(args[1]), TY_REAL) + call amovr (Memr[O_VALP(args[1])], Memr[O_VALP(o)], O_LEN(o)) + + case TY_DOUBLE: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_DOUBLE + call malloc (O_VALP(o), O_LEN(args[1]), TY_DOUBLE) + call amovd (Memd[O_VALP(args[1])], Memd[O_VALP(o)], O_LEN(o)) + + } + + } + + if (DEBUG) { call zzi_pevop (o) } + + call sfree (sp) +end diff --git a/pkg/dataio/import/generic/ipproc.x b/pkg/dataio/import/generic/ipproc.x new file mode 100644 index 00000000..def48b1c --- /dev/null +++ b/pkg/dataio/import/generic/ipproc.x @@ -0,0 +1,921 @@ +include +include +include +include "../import.h" + +define DEBUG false + + +# IP_PRBAND -- Process a band interleaved file. + +procedure ip_prband (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +int i, j, nlines, npix +int optype, nbytes_pix, percent +int cur_offset, band_offset, line_offset + +int ip_ptype() +long ip_lnote() + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + # Compute the offset between the same pixel in different bands. This + # is the area of the image plus any image padding, computed as a + # byte offset. + optype = ip_ptype (IO_TYPE(PTYPE(ip,1)),IO_NBYTES(PTYPE(ip,1))) + switch (optype) { + case TY_UBYTE: nbytes_pix = 1 + case TY_USHORT, TY_SHORT: nbytes_pix = SZB_CHAR * SZ_SHORT + case TY_INT: nbytes_pix = SZB_CHAR * SZ_INT32 + case TY_LONG: nbytes_pix = SZB_CHAR * SZ_LONG + case TY_REAL: nbytes_pix = SZB_CHAR * SZ_REAL + case TY_DOUBLE: nbytes_pix = SZB_CHAR * SZ_DOUBLE + } + band_offset = (IP_AXLEN(ip,1) * (IP_AXLEN(ip,2)-1)) + + ((IP_LSKIP(ip) + IP_LPAD(ip)) * (IP_AXLEN(ip,2)-1)) + + IP_BSKIP(ip) + band_offset = (band_offset * nbytes_pix) #+ 1 + + if (DEBUG) { + call eprintf ("ip_prband: band_offset=%d curpos=%d\n") + call pargi(band_offset) ; call pargi(ip_lnote(fd)) + call zzi_prstruct ("ip_prband", ip) + } + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + npix = IP_AXLEN(ip,1) + percent = 0 + do i = 1, nlines { + # Skip pixels at front of line + line_offset = ip_lnote (fd) + if (IP_LSKIP(ip) != 0) + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line and save as operand. + call ip_rdline (ip, fd, 1, npix, cmap) + + # Skip pixels at end of line. + if (IP_LPAD(ip) != 0) + call ip_lskip (fd, IP_LPAD(ip)) + cur_offset = ip_lnote (fd) + + # Loop over each of the remaining pixtypes. + do j = 2, IP_NPIXT(ip) { + # Seek to offset of next band (i.e. line_offset + band_offset). + call ip_lskip (fd, band_offset) + if (IP_LSKIP(ip) != 0) + call ip_lskip (fd, IP_LSKIP(ip)) + call ip_rdline (ip, fd, j, npix, cmap) # read pixels in the line + if (IP_LPAD(ip) != 0) + call ip_lskip (fd, IP_LPAD(ip)) + } + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + + # Restore file pointer to cur_offset. + call ip_lseek (fd, cur_offset) + } + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PRLINE -- Process a line interleaved file. + +procedure ip_prline (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +int i, j, nlines, npix, percent + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + if (DEBUG) { + call eprintf ("ip_prline:\n") + call zzi_prstruct ("ip_prline", ip) + } + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + npix = IP_AXLEN(ip,1) + percent = 0 + do i = 1, nlines { + + do j = 1, IP_NPIXT(ip) { + # Skip pixels at front of line + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line and save as operand. + call ip_rdline (ip, fd, j, npix, cmap) + + # Skip pixels at end of line. + call ip_lskip (fd, IP_LPAD(ip)) + } + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + } + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PRPIX -- Process a pixel interleaved file. + +procedure ip_prpix (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +pointer op, data +int i, swap, optype, nlines +int percent, npix, totpix + +int and(), ip_ptype() + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + if (DEBUG) { call eprintf ("ip_prpix: ") } + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Allocate the pixtype data pointers. + npix = IP_AXLEN(ip,1) + nlines = IP_NPIXT(ip) + do i = 1, nlines { + op = PTYPE(ip,i) + optype = ip_ptype (IO_TYPE(op),IO_NBYTES(op)) + IO_NPIX(op) = npix + if (IO_DATA(op) == NULL) + if (optype == TY_UBYTE) + call malloc (IO_DATA(op), npix, TY_SHORT) + else + call malloc (IO_DATA(op), npix, optype) + } + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + totpix = npix * IP_NPIXT(ip) + swap = IP_SWAP(ip) + percent = 0 + if (DEBUG) { + call zzi_prstruct ("ip_prpix", ip) + call eprintf ("nl=%d np=%d tp=%d:\n") + call pargi(nlines) ; call pargi(npix) ; call pargi(totpix) + } + do i = 1, nlines { + + # Skip pixels at front of line + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line. + switch (optype) { + case TY_UBYTE: + call ip_agetb (fd, data, totpix) + call ip_lskip (fd, totpix) + # Apply a colormap to the bytes. In general a pixel-interleaved + # file is a 24-bit True Color image, but maybe this is a + # 3-D color index file? + if (cmap != NULL && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], totpix, cmap) + + case TY_USHORT: + call ip_agetu (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (totpix*(SZ_SHORT*SZB_CHAR))) + } + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_SHORT))) + + + case TY_SHORT: + call ip_agets (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (totpix*(SZ_SHORT*SZB_CHAR))) + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_SHORT))) + + case TY_INT: + call ip_ageti (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I4) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Memi[data], Memi[data], totpix) + call bswap4 (Memi[data], 1, Memi[data], 1, + (totpix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Memi[data], 1, Memi[data], 1, + (totpix*(SZ_INT*SZB_CHAR))) + } + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_INT32))) + + case TY_LONG: + call ip_agetl (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I4) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Meml[data], Meml[data], totpix) + call bswap4 (Meml[data], 1, Meml[data], 1, + (totpix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Meml[data], 1, Meml[data], 1, + (totpix*(SZ_INT*SZB_CHAR))) + } + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_INT32))) + + case TY_REAL: + call ip_agetr (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL) { + call bswap4 (Memr[data], 1, Memr[data], 1, + (totpix*(SZ_REAL*SZB_CHAR))) + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_REAL))) + + case TY_DOUBLE: + call ip_agetd (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL) { + call bswap8 (Memd[data], 1, Memd[data], 1, + (totpix*(SZ_DOUBLE*SZB_CHAR))) + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_DOUBLE))) + + } + + # Skip pixels at end of line. + call ip_lskip (fd, IP_LPAD(ip)) + + # Separate pixels into different vectors. + call ip_upkpix (ip, data, npix) + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + } + + if (optype == TY_UBYTE) + call mfree (data, TY_SHORT) + else + call mfree (data, optype) + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PROBEXPR -- Process each of the outbands expressions and write the result +# to the output image. + +procedure ip_probexpr (ip, im, npix, line) + +pointer ip #i task struct pointer +pointer im #i output image pointer +int npix #i number of output pixels +int line #i line number + +int i +pointer out, ip_evaluate() + +begin + # Loop over outbands expressions. + do i = 1, IP_NBANDS(ip) { + # Evaluate outbands expression. + out = ip_evaluate (ip, O_EXPR(ip,i)) + + # Write bands to output image + if (IP_OUTPUT(ip) != IP_NONE) + call ip_wrline (ip, im, out, npix, line, i) + + call evvfree (out) + } +end + + +# IP_RDLINE -- Read a line of pixels from the binary file. + +procedure ip_rdline (ip, fd, pnum, npix, cmap) + +pointer ip #i task struct pointer +int fd #i input file descriptor +int pnum #i pixtype number +int npix #i number of pixels to read +pointer cmap #i colormap pointer + +pointer op, data +int swap, ptype + +int and(), ip_ptype() + +begin + # Read pixels in the line and save as operand. + op = PTYPE(ip,pnum) + ptype = ip_ptype (IO_TYPE(op), IO_NBYTES(op)) + data = IO_DATA(op) + swap = IP_SWAP(ip) + IO_NPIX(op) = npix + + switch (ptype) { + case TY_UBYTE: + call ip_agetb (fd, data, npix) + call ip_lskip (fd, npix) + # Apply a colormap to the bytes. If the colormap is non-null we + # assume the bytes are color indices into a colormap. + if (cmap != NULL && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], npix, cmap) + + case TY_USHORT: + call ip_agetu (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (npix*(SZ_SHORT*SZB_CHAR))) + } + call ip_lskip (fd, (npix * (SZB_CHAR * SZ_SHORT))) + + case TY_SHORT: + call ip_agets (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (npix*(SZ_SHORT*SZB_CHAR))) + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_SHORT)) + + case TY_INT: + call ip_ageti (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Memi[data], Memi[data], npix) + call bswap4 (Memi[data], 1, Memi[data], 1, + (npix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Memi[data], 1, Memi[data], 1, + (npix*(SZ_INT*SZB_CHAR))) + } + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_INT32)) + + case TY_LONG: + call ip_agetl (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Meml[data], Meml[data], npix) + call bswap4 (Meml[data], 1, Meml[data], 1, + (npix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Meml[data], 1, Meml[data], 1, + (npix*(SZ_LONG*SZB_CHAR))) + } + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_INT32)) + + case TY_REAL: + call ip_agetr (fd, data, npix) + if (and(swap, S_ALL) == S_ALL) { + call bswap4 (Memr[data], 1, Memr[data], 1, + (npix*(SZ_REAL*SZB_CHAR))) + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_REAL)) + + case TY_DOUBLE: + call ip_agetd (fd, data, npix) + if (and(swap, S_ALL) == S_ALL) { + call bswap8 (Memd[data], 1, Memd[data], 1, + (npix*(SZ_DOUBLE*SZB_CHAR))) + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_DOUBLE)) + + } + IO_DATA(op) = data +end + + +# IP_WRLINE -- Write a line of pixels to the output image. We handle image +# flipping here to avoid possibly doing it several times while the outbands +# expression is being evaluated. + +procedure ip_wrline (ip, im, out, npix, line, band) + +pointer ip #i task struct pointer +pointer im #i output image pointer +pointer out #i output operand pointer +int npix #i number of pixels to read +int line #i image line number +int band #i image band number + +int i, lnum, type +int nldone, blnum +pointer sp, dptr, data, optr +bool lastline + +int and() +pointer imps3s(), imps3i(), imps3l(), imps3r(), imps3d() +pointer ip_chtype() + +data blnum /0/ +data nldone /1/ +data lastline /false/ + +begin + call smark (sp) + + # The first thing we do is change the datatype of the operand to + # match the output pixel type. + if (IP_OUTTYPE(ip) != NULL) { + if (IP_OUTTYPE(ip) == O_TYPE(out)) + optr = O_VALP(out) + else + optr = ip_chtype (out, IP_OUTTYPE(ip)) + } + type = IP_OUTTYPE(ip) + + # See if we're flipping image in Y, and adjust the line number. + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + lnum = IP_AXLEN(ip,2) - line + 1 + if (band == 1) + blnum = IP_SZBUF(ip) - mod (line-1, IP_SZBUF(ip)) + lastline = (lnum == 1) + } else { + lnum = line + if (band == 1) + blnum = blnum + 1 + lastline = (lnum == IP_AXLEN(ip,2)) + } + + # See if we're flipping image in x, and reverse the pixels. + if (and(IP_FLIP(ip),FLIP_X) == FLIP_X) { + call salloc (dptr, npix, type) + do i = 1, npix { + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + Mems[dptr+i-1] = Mems[optr+(npix-i)] + + case TY_INT: + Memi[dptr+i-1] = Memi[optr+(npix-i)] + + case TY_LONG: + Meml[dptr+i-1] = Meml[optr+(npix-i)] + + case TY_REAL: + Memr[dptr+i-1] = Memr[optr+(npix-i)] + + case TY_DOUBLE: + Memd[dptr+i-1] = Memd[optr+(npix-i)] + + } + } + } else + dptr = optr + + # Make sure the image pixtype is set. + if (IM_PIXTYPE(im) == NULL) + IM_PIXTYPE(im) = type + + # Allocate the buffer pointer if needed. + if (BUFFER(ip,band) == NULL) + call calloc (BUFFER(ip,band), npix*IP_SZBUF(ip), IP_OUTTYPE(ip)) + + if (nldone < IP_SZBUF(ip) && !lastline) { + # Copy the image line to the buffer + data = BUFFER(ip,band) + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovs (Mems[dptr], Mems[data+((blnum-1)*npix)], npix) + + case TY_INT: + call amovi (Memi[dptr], Memi[data+((blnum-1)*npix)], npix) + + case TY_LONG: + call amovl (Meml[dptr], Meml[data+((blnum-1)*npix)], npix) + + case TY_REAL: + call amovr (Memr[dptr], Memr[data+((blnum-1)*npix)], npix) + + case TY_DOUBLE: + call amovd (Memd[dptr], Memd[data+((blnum-1)*npix)], npix) + + } + if (band == IP_NBANDS(ip)) + nldone = nldone + 1 + + } else { + # Write the buffer to the image as a section. + data = BUFFER(ip,band) + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovs (Mems[dptr], Mems[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3s (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovs (Mems[BUFFER(ip,band)+(blnum-1)*npix], + Mems[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3s (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovs (Mems[BUFFER(ip,band)], Mems[data], npix*blnum) + } + + case TY_INT: + call amovi (Memi[dptr], Memi[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3i (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovi (Memi[BUFFER(ip,band)+(blnum-1)*npix], + Memi[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3i (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovi (Memi[BUFFER(ip,band)], Memi[data], + npix*blnum) + } + + case TY_LONG: + call amovl (Meml[dptr], Meml[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3l (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovl (Meml[BUFFER(ip,band)+(blnum-1)*npix], + Meml[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3l (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovl (Meml[BUFFER(ip,band)], Meml[data], + npix*blnum) + } + + case TY_REAL: + call amovr (Memr[dptr], Memr[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3r (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovr (Memr[BUFFER(ip,band)+(blnum-1)*npix], + Memr[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3r (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovr (Memr[BUFFER(ip,band)], Memr[data], + npix*blnum) + } + + case TY_DOUBLE: + call amovd (Memd[dptr], Memd[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3d (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovd (Memd[BUFFER(ip,band)+(blnum-1)*npix], + Memd[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3d (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovd (Memd[BUFFER(ip,band)], Memd[data], + npix*blnum) + } + + } + if (band == IP_NBANDS(ip)) { + nldone = 1 + blnum = 0 + } + } + + if (IP_OUTTYPE(ip) != O_TYPE(out)) + call mfree (optr, type) + call sfree (sp) +end + + +# IP_UPKPIX -- Unpack a line of pixel-interleaved pixels to the separate +# pixtype operand arrays. + +procedure ip_upkpix (ip, ptr, npix) + +pointer ip #i task struct pointer +pointer ptr #i pointer to pixels +int npix #i number of pixels in line + +pointer op[IM_MAXDIM] +int i, j, np, optype[IM_MAXDIM] + +int ip_ptype() + +begin + np = IP_NPIXT(ip) + do j = 1, np { + op[j] = PTYPE(ip,j) + optype[j] = ip_ptype (IO_TYPE(op[j]),IO_NBYTES(op[j])) + } + + do j = 1, np { + + do i = 0, npix-1 { + switch (optype[j]) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + Mems[IO_DATA(op[j])+i] = Mems[ptr+(i*np+j)-1] + + case TY_INT: + Memi[IO_DATA(op[j])+i] = Memi[ptr+(i*np+j)-1] + + case TY_LONG: + Meml[IO_DATA(op[j])+i] = Meml[ptr+(i*np+j)-1] + + case TY_REAL: + Memr[IO_DATA(op[j])+i] = Memr[ptr+(i*np+j)-1] + + case TY_DOUBLE: + Memd[IO_DATA(op[j])+i] = Memd[ptr+(i*np+j)-1] + + } + } + } +end + + +# IP_FIX_PIXTYPE -- Create the pixtype operands for 3-D band or line- +# interleaved files. These weren't allocated at first since the pixtype +# parameter or database field was atomic. + +procedure ip_fix_pixtype (ip) + +pointer ip #i task struct pointer + +pointer op, op1 +int i, nnp + +begin + if (DEBUG) { + call eprintf ("fix_pixtype: npixt=%d ndim=%d inter=%d\n") + call pargi(IP_NPIXT(ip)) ; call pargi(IP_NDIM(ip)) + call pargi(IP_INTERLEAVE(ip)) ; call flush (STDERR) + } + + # See if there's anything to be fixed. + if (IP_NDIM(ip) < 3 || IP_NDIM(ip) < IP_NPIXT(ip)) + return + if (BAND_INTERLEAVED(ip) && (IP_NPIXT(ip) == IP_NDIM(ip))) + return + if (LINE_INTERLEAVED(ip) && (IP_NPIXT(ip) == IP_INTERLEAVE(ip))) + return + + if (LINE_INTERLEAVED(ip)) + nnp = IP_INTERLEAVE(ip) + else + #nnp = IP_NDIM(ip) + nnp = IP_AXLEN(ip,3) + + # Make the new pixtype operands. + op1 = PTYPE(ip,1) + do i = 2, nnp { + call ip_alloc_operand (PTYPE(ip,i)) + op = PTYPE(ip,i) + IO_TYPE(op) = IO_TYPE(op1) + IO_NBYTES(op) = IO_NBYTES(op1) + call sprintf (OP_TAG(op), SZ_TAG, "b%d") + call pargi (i) + } + IP_NPIXT(ip) = nnp + + if (DEBUG) { call zzi_prstruct ("fix_pixtype", ip) } +end + + +# IP_FIX_OUTBANDS -- Create the outbands operands if none were specified in +# the parameter file. + +procedure ip_fix_outbands (ip) + +pointer ip #i task struct pointer + +pointer sp, buf +pointer im +int i, nbands + +define SZ_OBSTR 2500 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + if (DEBUG) { + call eprintf ("fix_outbands: npixt=%d ndim=%d inter=%d\n") + call pargi(IP_NPIXT(ip)) ; call pargi(IP_NDIM(ip)) + call pargi(IP_INTERLEAVE(ip)) ; call flush (STDERR) + } + + # Free up the existing outbands operands. + nbands = IP_NBANDS(ip) + do i = 1, nbands + call ip_free_outbands (OBANDS(ip,i)) + + # Create an outbands parameter string according to the tags in the + # pixtype structure. This way we preserve any user-defined tags on + # output. + nbands = IP_NPIXT(ip) + call aclrc (Memc[buf], SZ_FNAME) + do i = 1, nbands { + call ip_alloc_outbands (OBANDS(ip,i)) + call aclrc (Memc[buf], SZ_FNAME) + call sprintf (Memc[buf], SZ_FNAME, "b%d") + call pargi (i) + call strcpy (Memc[buf], O_EXPR(ip,i), SZ_EXPR) + + # Load the operand struct. + call strcpy (Memc[buf], OP_TAG(O_OP(ip,i)), SZ_EXPR) + } + IP_NBANDS(ip) = nbands + + # Fix the output image dimensions. + im = IP_IM(ip) + IM_LEN(im,3) = IP_AXLEN(ip,3) + if (IP_NBANDS(ip) > 1) + IM_NDIM(im) = 3 + else + IM_NDIM(im) = IP_NDIM(ip) + + call sfree (sp) + + if (DEBUG) { call zzi_prstruct ("fix_outbands", ip) } +end + + +# IP_CHTYPE - Change the expression operand vector to the output datatype. +# We allocate and return a pointer to the correct type to the converted +# pixels, this pointer must be freed later on. + +pointer procedure ip_chtype (op, type) + +pointer op #i evvexpr operand pointer +int type #i new type of pointer + +pointer out, coerce() + +begin + # Allocate the pointer and coerce it so the routine works. + if (type == TY_UBYTE || type == TY_CHAR) + call calloc (out, O_LEN(op), TY_CHAR) + else { + call calloc (out, O_LEN(op), type) + out = coerce (out, type, TY_CHAR) + } + + # Change the pixel type. + switch (O_TYPE(op)) { + case TY_CHAR: + call achtc (Memc[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_SHORT: + call achts (Mems[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_INT: + call achti (Memi[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_LONG: + call achtl (Meml[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_REAL: + call achtr (Memr[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_DOUBLE: + call achtd (Memd[O_VALP(op)], Memc[out], O_LEN(op), type) + default: + call error (0, "Invalid output type requested.") + } + + out = coerce (out, TY_CHAR, type) + return (out) +end + + +define NTYPES 6 +define NBITPIX 4 + +# IP_PTYPE -- For a given pixtype parameter return the corresponding IRAF +# data type. + +int procedure ip_ptype (type, nbytes) + +int type #i pixel type +int nbytes #i number of bytes + +int i, pt, pb, ptype +int tindex[NTYPES], bindex[NBITPIX], ttbl[NTYPES*NBITPIX] + +data tindex /PT_BYTE, PT_UINT, PT_INT, PT_IEEE, PT_NATIVE, PT_SKIP/ +data bindex /1, 2, 4, 8/ + +data (ttbl(i), i= 1, 4) /TY_UBYTE, TY_USHORT, TY_INT, 0/ # B +data (ttbl(i), i= 5, 8) /TY_UBYTE, TY_USHORT, 0, 0/ # U +data (ttbl(i), i= 9,12) /TY_UBYTE, TY_SHORT, TY_INT, 0/ # I +data (ttbl(i), i=13,16) / 0, 0, TY_REAL, TY_DOUBLE/ # R +data (ttbl(i), i=17,20) / 0, 0, TY_REAL, TY_DOUBLE/ # N +data (ttbl(i), i=21,24) /TY_UBYTE, TY_USHORT, TY_REAL, TY_DOUBLE/ # X + +begin + if (type == 0 || nbytes == 0) # uninitialized values + return (0) + + pt = NTYPES + do i = 1, NTYPES { + if (tindex[i] == type) + pt = i + } + pb = NBITPIX + do i = 1, NBITPIX { + if (bindex[i] == nbytes) + pb = i + } + + ptype = ttbl[(pt-1)*NBITPIX+pb] + if (ptype == 0) + call error (0, "Invalid pixtype specified.") + else + return (ptype) +end + + +# IP_PSTAT - Print information about the progress we're making. + +procedure ip_pstat (ip, row, percent) + +pointer ip #i task struct pointer +int row #u current row +int percent #u percent completed + +begin + # Print percent done if being verbose + if (row * 100 / IP_AXLEN(ip,2) >= percent + 10) { + percent = percent + 10 + call eprintf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDERR) + } +end diff --git a/pkg/dataio/import/generic/mkpkg b/pkg/dataio/import/generic/mkpkg new file mode 100644 index 00000000..9e8721db --- /dev/null +++ b/pkg/dataio/import/generic/mkpkg @@ -0,0 +1,15 @@ +# Compile the generic sources. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + ipdb.x ../import.h ../ipfcn.h \ + + ipfio.x ../import.h + ipobands.x ../import.h ../ipfcn.h \ + + ipproc.x ../import.h + ; diff --git a/pkg/dataio/import/images.dat b/pkg/dataio/import/images.dat new file mode 100644 index 00000000..dd8123ce --- /dev/null +++ b/pkg/dataio/import/images.dat @@ -0,0 +1,433 @@ +# IMAGES.DAT -- Database of known formats recognized by the IMPORT task. +# +# Each record of the database is of the form: +# +# : +# : +# : +# keyword = +# keyword = +# ...and so on +# +# A database record begins with the format name at the beginning of a line. +# Whitespace at the beginning of a line is considered the continuation of a +# previous line. Comments may be inserted in the database using the normal '#' +# character, the remainder of the line is considered a comment. Blank lines +# and comments are ignored, a record ends at the next line with a format name +# at the beginning of the line. +# +# The format_name field is a string identifying each entry in the +# database, an alias may also be given to identify the same field if known +# by another name. Supported keywords include: +# +# image_id - A boolean expression identifying the image type, either +# using a literal string or one of the provided functions +# id_string - Verbose name of file format +# bswap - Is file byte-swapped? (See Below) +# dims - A whitespace/comma delimited string of image dimension +# pixtype - Pixel type, size [and tag], may be a composite +# interleave - Describes how pixels are stored +# hskip - # of bytes of header info to skip +# tskip - # of bytes of trailing info to skip at end of file +# bskip - # of bytes of info to skip between image bands +# lskip - # of bytes of info to skip at the front of each line +# lpad - # of bytes of info to skip at the end of each line +# yflip - Image is flipped relative to normal IRAF orientation +# comment - (Multiple) informational comment string to be printed, +# e.g. to warn the user about the pixel ordering. +# error - A condition that would cause a file read error, returns +# a string with the error message, otherwise NULL +# +# Expressions include not only functions supported by the system expression +# evaluator but also special functions particular to the IMPORT task. The +# user is referred to the IMPORT help page for more details on the database +# functions. +# +# Expressions may also contain *previously defined* database fields, so for +# instance the 'hskip' keyword can be computed in an expression using the +# value of the 'pixtype' keyword. Additionally, several special operands are +# also supported and may be used in expressions: +# +# $FSIZE - the size in bytes of the binary file +# $FNAME - the name of the binary file + + + +avs: # AVS X image file +mbfx: +mbfavs: +x: + image_id = ($FSIZE - (geti4(1) * geti4(5) * 4) == 8) + id_string = "AVS X Image Format file" + dims = (str(geti4(1)) // "," // str(geti4(5))) // ",4" + pixtype = "x1,b1,b1,b1" + hskip = 8 + yflip = 1 + comment = "Note: The first band of this image is an alpha channel." + + +clementine: # CLEMENTINE mission image +pds3: + image_id = (getstr(1,23) == "PDS_VERSION_ID = PDS3") + id_string = "CLEMENTINE 1 PDS3 image data file" + pixtype = "b1" + hskip = int(locate(1,"OBJECT = IMAGE\r\n")+16) + bskip = int(locate(hskip,"LINE_SAMPLES")) + lskip = int(locate(hskip,"LINES")) +# dims = ((str(ctoi((locate(hskip,"LINE_SAMPLES")+17)))) // "," // +# (str(ctoi((locate(hskip,"LINES")+17)))) ) + dims = ((str(ctoi((locate(bskip,"=")+1)))) // "," // + (str(ctoi((locate(lskip,"=")+1)))) ) + hskip = (ctoi(locate(1,"^IMAGE ")+18)) + bskip = 0 + lskip = 0 + yflip = 0 + + +export: # EXPORT task output format + image_id = (getstr(1,15) == "format = EXPORT") + id_string = "IRAF EXPORT file (with header)" + bswap = (getstr(locate(1,"bswap")+9,locate(1,"bswap")+11) == "no") + hskip = ctoi(locate(1,"hdrsize =")+10) + pixtype = (getstr(locate(1,"datatype = '")+12,2)) + dims = ((ctoi(locate(1,"nbands =")+8) > 1) ? + (str(ctoi(locate(1,"ncols = ")+8)) // "," // + str(ctoi(locate(1,"nrows = ")+8)) // "," // + str(ctoi(locate(1,"nbands = ")+9))) + : (str(ctoi(locate(1,"ncols = ")+8)) // "," // + str(ctoi(locate(1,"nrows = ")+8)))) + interleave = ctoi(locate(1,"interleave =")+13) + + +fits: # Uhh, use RFITS for this + bswap = parameter ("bswap") + image_id = (getstr(1,9) == "SIMPLE =") + id_string = "FITS Format image" + hskip = ( int (locate(1,"END ") / 2800) ) * 2880 + pixtype = ( str (ctoi((locate(1,"BITPIX")+10))) ) + pixtype = ((pixtype == "8" ? "b1" : + (pixtype == "16" ? "i2" : + (pixtype == "32" ? "i4" : + (pixtype == "-32" ? "r4" : + (pixtype == "-64" ? "r8" : "0")))))) + dims = ((ctoi(locate(1,"NAXIS ")+10) == 3) ? + (str(ctoi(locate(1,"NAXIS1")+10)) // "," // + str(ctoi(locate(1,"NAXIS2")+10)) // "," // + str(ctoi(locate(1,"NAXIS3")+10))) + : (str(ctoi(locate(1,"NAXIS1")+10)) // "," // + str(ctoi(locate(1,"NAXIS2")+10)))) + + +gif: # CompuServe's GIF format +giff: + image_id = ( (getstr(1,6) == "GIF87a") || (getstr(1,6) == "GIF89a") ) + id_string = "CompuServe GIF Format File" + dims = (str((getb(7)+(256*getb(8)))) //","// str((getb(9)+(256*getb(10))))) + pixtype = "u1" + hskip = 22 + yflip = 1 + comment = "Note: Colormap information will automatically be applied." + + +oif: # An IRAF OIF pixel file +imh: +iraf: + bswap = (geti2(1) == 26880 && # bswap("impix" in SPP chars) + geti2(3) == 27904 && + geti2(5) == 28672 && + geti2(7) == 26880 && + geti2(9) == 30720) + image_id = (geti2(1) == 105 && # "impix" in SPP chars + geti2(3) == 109 && + geti2(5) == 112 && + geti2(7) == 105 && + geti2(9) == 120) + id_string = "IRAF OIF image pixel file" + dims = ((geti2(23) == 3) ? + (str(geti2(27)) //","// str(geti2(31)) //","// str(geti2(35))) + : (str(geti2(27)) //","// str(geti2(31))) ) + pixtype = ((geti2(17) == 3 ? "i2" : + (geti2(17) == 4 ? "i4" : + (geti2(17) == 5 ? "i4" : + (geti2(17) == 6 ? "n4" : + (geti2(17) == 7 ? "n8" : ""))))) ) + hskip = 1024 + lpad = (geti2(55) - geti2(27)) + lpad = (lpad * ((geti2(17) == 3 ? (2) : + (geti2(17) == 4 ? (4) : + (geti2(17) == 5 ? (4) : + (geti2(17) == 6 ? (4) : + (geti2(17) == 7 ? (8) : (1))))))) ) + error = (geti2(23) > 3) ? "Maximum of 3 dimensions supported." : "okay" + error = ((geti2(17) > 7) || (geti2(17) < 3)) ? + "Image data type not supported." : "okay" + + +mcidas: # Unidata McIDAS file + image_id = (geti4(5) == 4) + id_string = "McIDAS" + dims = (str(geti4(37)) // "," // str(geti4(33))) + pixtype = "b1" + hskip = geti4(133) + lskip = geti4(57) + yflip = 1 + + +miff: # ImageMagick MIFF format +mif: + image_id = (locate(1,"id=ImageMagick") < locate (1,":\n")) + id_string = "ImageMagick MIFF format file" + hskip = ((locate(1,":\n") + 1) + (ctoi(locate(1,"colors=")+7) * 3) + 1) + dims = (str(ctoi(locate(1,"columns=")+8)) // "," // + str(ctoi(locate(1,"rows=")+5)) ) + yflip = 1 + pixtype = (getstr(locate(1,"class=")+6,6) == "Direct" ? "b1,b1,b1" : + ((ctoi(locate(1,"colors=")+7) > 256) ? "b2" : "b1")) + error = locate(1,"compression") > 1 ? + "Compressed files not supported" : "okay" + error = ctoi(locate(1,"colors=")+7) > 256 ? + "Too many entries in colormap" : "okay" + comment = "Note: Colormaps will not be applied to image." + + +pgm: # PBMPlus PGM format +rpgm: + image_id = (getstr(1,2) == "P5" || getstr(1,2) == "P2") + id_string = "PBMPlus PGM format file" + pixtype = "b1" + hskip = ((str(getstr(line(2),1)) != "#") ? # see if there's a comment + (int(line(4) - 1)) + : (int(line(5) - 1)) ) + dims = ((str(getstr(line(2),1)) != "#") ? + (str(ctoi(line(2))) // "," // str(ctoi(locate(line(2)," ")))) + : (str(ctoi(line(3))) // "," // str(ctoi(locate(line(3)," ")))) ) + yflip = 1 + error = getstr(1,2) == "5P" ? "File is byte-swapped" : "okay" + error = getstr(1,2) == "P2" ? "Only raw PGM files are supported." : "okay" + + +ppm: # PBMPlus PPM format +pnm: +rppm: + image_id = (getstr(1,2) == "P6" || getstr(1,2) == "P3") + id_string = "PBMPlus PPM format file" + pixtype = "b1,b1,b1" + hskip = ((str(getstr(line(2),1)) != "#") ? # see if there's a comment + (int(line(4) - 1)) + : (int(line(5) - 1)) ) + dims = ((str(getstr(line(2),1)) != "#") ? + (str(ctoi(line(2))) // "," // str(ctoi(locate(line(2)," ")))) + : (str(ctoi(line(3))) // "," // str(ctoi(locate(line(3)," ")))) ) + dims = dims // ",3" + yflip = 1 + error = getstr(1,2) == "6P" ? "File is byte-swapped" : "okay" + error = getstr(1,2) == "P3" ? "Only raw PGM files are supported." : "okay" + + +rgb: # SGI RGB format image +iris: +sgi: + bswap = (getu(1) == bswap(0732b)) + image_id = (getu(1) == 0732b) + id_string = "SGI RGB Image file" + dims = ((geti2(5) == 3) ? + (str(geti2(7)) // "," // str(geti2(9)) // "," // str(geti2(11))) + : (str(geti2(7)) // "," // str(geti2(9))) ) + pixtype = "b1" + hskip = 512 + interleave = 0 + error = (geti2(3) == 3) ? "Colormap files not supported" : "okay" + error = ((geti2(3) != 0) && (geti2(3) != 1)) ? + "Format of RGB file not supported" : "okay" + error = (geti2(3) == 257) ? "RLE compressed files not supported" : "okay" + + +sunras: # Sun rasterfile +ras: + bswap = (geti4(1) == bswap(59a66a95x)) + image_id = (geti4(1) == 59a66a95x || bswap) + id_string = "Sun Rasterfile" + dims = (str(geti4(5)) // "," // str(geti4(9)) // + ((geti4(13) > 8) ? ("," // str(3)) : " ") ) + pixtype = ((geti4(13) == 8 ? "b1" : + (geti4(13) == 24 ? "b1,b1,b1" : + (geti4(13) == 32 ? "x1,b1,b1,b1" : "x1,b1,b1,b1") )) ) + interleave = 0 + hskip = (32 + geti4(29)) + yflip = 1 + comment = "Note: Colormaps will automatically be applied to 8-bit images." + error = geti4(13) == 1 ? "1-bit rasters not supported." : "okay" + + +iff: # Sun TAAC Image File Format +taac: +vff: +suniff: + image_id = (getstr(1,4) == "ncaa") + id_string = "Sun TAAC Image File Format" + dims = (str(ctoi(locate(1,"size=")+5)) // "," // + str(ctoi(locate((locate(1,"size=")+5)," "))) ) + dims = ((ctoi((locate(1,"bands=")+6)) == 3) ? (dims // ",3") : dims ) + hskip = $FSIZE - (ctoi(locate(1,"size=")+5) * + ctoi(locate((locate(1,"size=")+5)," ")) * + ctoi((locate(1,"bands=")+6)) ) + pixtype = ((ctoi((locate(1,"bands=")+6)) == 3) ? "b1,b1,b1" : "b1" ) + yflip = 1 + comment = "Note: Colormaps will not be applied to 8-bit images." + + +vicar: # VICAR format file + bswap = ( msb_host() && (getstr((locate(1,"INTFMT=")+8),3) == "LOW") ) + image_id = (getstr(1,8) == "LBLSIZE=") + id_string = "VICAR format image data file" + hskip = (ctoi((locate(1,"LBLSIZE=")+8)) + + (ctoi((locate(1,"NLB=")+4)) * ctoi((locate(1,"RECSIZE=")+8)))) + lskip = (ctoi((locate(1,"NBB=")+4))) + interleave = (((getstr((locate(1,"ORG=")+5),3))) == "BSQ" ? 0 : + ((getstr((locate(1,"ORG=")+5),3)) == "BIL" ? + ctoi(locate(1,"NB=")+3) : 999) ) + pixtype = (getstr((locate(1,"FORMAT=")+8),4)) + pixtype = ((pixtype == "BYTE" ? "b1" : + (pixtype == "HALF" ? "i2" : + (pixtype == "FULL" ? "i4" : + (pixtype == "REAL" ? "r4" : + (pixtype == "DOUB" ? "r8" : "0")))))) + pixtype = (((interleave) != 999) ? pixtype : + ((ctoi(locate(1,"DIM=")+5) == 2) ? + pixtype // "," // pixtype : + ((ctoi(locate(1,"DIM=")+5) == 3) ? + pixtype // "," // pixtype // "," // pixtype : + (pixtype) )) ) + dims = (((ctoi(locate(1,"DIM=")+4)==3) && (ctoi(locate(1,"N3=")+3)!=1)) ? + (str(ctoi(locate(1,"N1=")+3)) // "," // + str(ctoi(locate(1,"N2=")+3)) // "," // + str(ctoi(locate(1,"N3=")+3))) + : (str(ctoi(locate(1,"N1=")+3)) // "," // + str(ctoi(locate(1,"N2=")+3)))) + yflip = 1 + error = ((getstr((locate(1,"TYPE=")+6),5) != "IMAGE") ? + "Not a VICAR image file." : "okay") + error = ((getstr((locate(1,"FORMAT=")+8),4) == "COMP") ? + "Complex image data not supported" : "okay") + + +x10: # X10 Window Dump file +x10wd: + image_id = (geti4(5) == 6) + id_string = "X10 Window Dump file" + hskip = ( geti4(1) + (10 * geti2(39)) ) + pixtype = "b1" + dims = (str(geti4(21)) // "," // str(geti4(25))) + comment = "Note: Colormaps will not be applied to image." + + +xwd: # X11 Window Dump file +x11: +x11wd: + #bswap = ( msb_host() && (geti4(29) == 0) ) + image_id = (geti4(5) == 7) + id_string = "X11 Window Dump file" + dims = (str(geti4(17)) // "," // str(geti4(21))) + dims = ( (geti4(45) == 24) ? str (dims // ",3") : dims ) # add dims + dims = ( (geti4(45) == 32) ? str (dims // ",4") : dims ) # add dims + hskip = ( geti4(1) + (12 * geti4(73)) ) + # On a 64-bit machine the colormap struct is 16 bytes long instead of + # 12, see if we have one of these files and pad the header. + hskip = ( ((geti4(17)*geti4(21)*(geti4(45)/8)) + hskip) < ($FSIZE-1024) ? + (hskip + (4*geti4(73))) : hskip) + lpad = ( geti4(49) - (geti4(17) * (geti4(45) / 8)) ) + pixtype = ( (geti4(45) == 8) ? "b1" : + (geti4(45) == 24) ? "b1,b1,b1" : + (geti4(45) == 32) ? "x1,b1,b1,b1" : "x1,b1,b1,b1" ) + yflip = 1 + + + +######################################################################### +# # +# The following database entries are not supported for conversion but # +# are provided for file identification purposes. # +# # +######################################################################### + + +cmuwmraster: # CMU Window Manager Raster + bswap = (geti4(1) == bswap(00F10040BBx)) + image_id = (geti4(1) == 00F10040BBx || bswap) + id_string = "CMU Window manager Raster file (ID only)" + dims = (str(geti4(5)) // "," // str(geti4(9)) // "," // str(geti2(11))) + error = (1 == 1) ? "CMU raster supported for file identification only." : + "okay" + + +fbm: # Fuzzy Bitmap Format file + image_id = (getstr(1,7) == "%bitmap") + id_string = "Fuzzy Bitmap Format file (ID only)" + dims = (str(ctoi(getstr(17,8))) // "," // str(ctoi(getstr(9,8)))) + error = (1 == 1) ? "FBM supported for file identification only." : + "okay" + + +hdf: # NCSA Hierarchical Data File +df: +ncsa: + bswap = ( lsb_host() ) + image_id = (geti4(1) == 0e031301x) + id_string = "NCSA Hierarchical Data File (ID only)" + dims = (str(geti2(822)) // "," // str(geti2(826))) + error = (1 == 1) ? "NCSA HDF supported for file identification only." : + "okay" + +msp: # Microsoft Paint Bitmap + bswap = (geti2(1) == bswap(01800x) || geti2(1) == bswap(0694Cx)) + image_id = ((geti2(1) == 01800x && geti2(3) == 04D6Ex) || + (geti2(1) == 0694Cx && geti2(3) == 0536Ex)) + id_string = "Microsoft Paint Bitmap (ID only)" + dims = (str(geti2(5)) // "," // str(geti2(7))) + error = (1 == 1) ? "MSP supported for file identification only." : + "okay" + +pcx: # PC Paintbrush File Format +dcx: +pcc: + image_id = (getb(1) == 010x) + id_string = "PC Paintbrush File (ID only)" + dims = (str(geti2(9) - geti2(5) + 1) // "," // + str(geti2(11) - geti2(7) + 1)) + error = (1 == 1) ? "PC Paintbrush supported for file identification only." : + "okay" + +pic: # Pictor PC Paint +clp: + bswap = (geti2(1) == bswap(01234x)) + image_id = (geti2(1) == 01234x) + id_string = "Pictor PC Paint bitmap (ID only)" + dims = (str(geti2(3)) // "," // str(geti2(5))) + error = (1 == 1) ? "PC Paint supported for file identification only." : + "okay" + +ps: # Postscript file +postscript: + image_id = (getstr(1,2) == "%!") + id_string = "Postscript file (ID only)" + error = (1 == 1) ? "PS supported for file identification only." : + "okay" + + +rle: # Utah Raster Toolkit file +utah: + image_id = (getb(1) == 52x || getb(1) == 00CCx) + id_string = "Utah Raster Toolkit Format file (ID only)" + error = (1 == 1) ? "RLE supported for file identification only." : + "okay" + + +tif: # TIFF format file +tiff: + bswap = (geti2(1) == bswap(4949x) || geti2(1) == bswap(4D4Dx)) + image_id = ((geti2(1) == 4D4Dx && geti2(3) == 002Ax) || + (geti2(1) == 4949x && geti2(3) == 2A00x)) + id_string = "TIFF Format file (ID only)" + error = (1 == 1) ? "TIFF supported for file identification only." : + "okay" + diff --git a/pkg/dataio/import/import.h b/pkg/dataio/import/import.h new file mode 100644 index 00000000..6d80020a --- /dev/null +++ b/pkg/dataio/import/import.h @@ -0,0 +1,132 @@ +# IMPORT.H - Data structure definition file for the IMPORT task. + +define SZ_IMPSTRUCT 40 # size of the import structure +define SZ_EXPR (20*SZ_LINE) # max size of an expression +define SZ_COMMENT 1024 # size of a database format comment +define LEN_UA 20000 # minimum user header length +define MAX_OPERANDS 1024 + +# Input format parameters. +define IP_INTERLEAVE Memi[$1] # type of data interleaving +define IP_HSKIP Memi[$1+1] # bytes to skip before data +define IP_TSKIP Memi[$1+2] # bytes to skip after data +define IP_BSKIP Memi[$1+3] # bytes between image bands +define IP_LSKIP Memi[$1+4] # bytes to skip at front of line +define IP_LPAD Memi[$1+5] # bytes to skip at end of line +define IP_SWAP Memi[$1+6] # type of byte swapping +define IP_NPIXT Memi[$1+7] # number of pixtypes +define IP_PIXTYPE Memi[$1+8] # pixtype ptr to operands +define IP_NDIM Memi[$1+9] # number of input axes +define IP_AXLEN Memi[($1+10)+$2-1] # input axis dimension + +# Output parameters. +define IP_OUTPUT Memi[$1+20] # type of output generated +define IP_OUTTYPE Memi[$1+21] # output pixel type +define IP_NBANDS Memi[$1+22] # no. of outbands expr string +define IP_OUTBANDS Memi[$1+23] # outbands expr string (ptr) +define IP_IMHEADER Memi[$1+24] # file w/ header info (ptr) +define IP_VERBOSE Memi[$1+25] # verbose output flag + +define IP_FORMAT Memi[$1+26] # format param +define IP_BLTIN Memi[$1+27] # format is a 'builtin' +define IP_FCODE Memi[$1+28] # builtin format code +define IP_FSYM Memi[$1+29] # symtab pointer to db record +define IP_IM Memi[$1+30] # output image pointer +define IP_FD Memi[$1+31] # binary file pointer +define IP_OFFSET Memi[$1+32] # binary file offset +define IP_FLIP Memi[$1+33] # output image orientation flag +define IP_COMPTR Memi[$1+34] # comment block pointer + +define IP_BUFPTR Memi[$1+35] # array of image buffers (ptr) +define IP_NPTRS Memi[$1+36] # number of image buffer +define IP_SZBUF Memi[$1+37] # size of image buffer (lines) + +define IP_CMAP Memi[$1+38] # image colormap (ptr) +define IP_USE_CMAP Memi[$1+39] # use the image colormap? + +# Useful Macros +define PTYPE Memi[IP_PIXTYPE($1)+$2-1] +define OBANDS Memi[IP_OUTBANDS($1)+$2-1] +define COMMENT Memc[IP_COMPTR($1)] +define BUFFER Memi[IP_BUFPTR($1)+$2-1] + + +#----------------------------------------------------------------------------- + +# Outbands structure +define LEN_OUTBANDS 2 +define OB_EXPR Memi[$1] # expression string +define OB_OP Memi[$1+1] # operand struct pointer +define O_EXPR Memc[OB_EXPR(OBANDS($1,$2))] +define O_OP OB_OP(OBANDS($1,$2)) + +# Operand structure +define SZ_TAG 15 +define LEN_OPERAND 6 +define IO_TAG Memi[$1] # operand tag name +define IO_TYPE Memi[$1+1] # operand type +define IO_NBYTES Memi[$1+2] # number of bytes +define IO_NPIX Memi[$1+3] # number of pixels +define IO_DATA Memi[$1+4] # line of pixels +define OP_TAG Memc[IO_TAG($1)] + + +# Format type flags +define IP_NONE 1 # format derived from task params +define IP_SENSE 2 # format divined from database +define IP_NAME 3 # format derived from database +define IP_BUILTIN 4 # format derived from database + +# Output type flags +define IP_IMAGE 5 # generate an output image +define IP_LIST 6 # list pixels (according to 'outbands') +define IP_INFO 7 # print info about image format + +# Byte swapping flags +define S_NONE 000B # swap nothing +define S_ALL 001B # swap everything +define S_I2 002B # swap short ints +define S_I4 004B # swap long ints +define SWAP_STR "|no|none|yes|i2|i4|" + +# Image flipping flags +define FLIP_NONE 000B # don't flip the image +define FLIP_X 001B # flip image in X +define FLIP_Y 002B # flip image in Y + +# Pixtype pixel types +define PT_BYTE 1 # byte data (no conversion) +define PT_UINT 2 # unsigned integer +define PT_INT 3 # signed integer +define PT_IEEE 4 # ieee floating point +define PT_NATIVE 5 # native floating point +define PT_SKIP 6 # skip + +# Default task parameters. +define DEF_SWAP S_NONE +define DEF_INTERLEAVE 0 +define DEF_HSKIP 0 +define DEF_TSKIP 0 +define DEF_BSKIP 0 +define DEF_LSKIP 0 +define DEF_LPAD 0 + +# Useful macros. +define BAND_INTERLEAVED ((IP_NPIXT($1)==1)&&(IP_INTERLEAVE($1)==0)) +define LINE_INTERLEAVED ((IP_NPIXT($1)==1)&&(IP_INTERLEAVE($1)>1)) +define PIXEL_INTERLEAVED ((IP_NPIXT($1)>1)&&(IP_INTERLEAVE(ip)==0)) + +# NTSC grayscale coefficients. +define R_COEFF 0.299 +define G_COEFF 0.587 +define B_COEFF 0.114 + +# Colormap definitions. +define CMAP_SIZE 256 # Output colormap length +define CMAP_MAX 255 # Maximum map value +define CMAP Memc[$1+($2*CMAP_SIZE)+$3-1] + +define IP_RED 0 +define IP_GREEN 1 +define IP_BLUE 2 + diff --git a/pkg/dataio/import/ipbuiltin.x b/pkg/dataio/import/ipbuiltin.x new file mode 100644 index 00000000..e95719be --- /dev/null +++ b/pkg/dataio/import/ipbuiltin.x @@ -0,0 +1,91 @@ +include "import.h" + + +# Define the builtin format names. We also define the aliases in case the +# user specifies one of these instead, the 'sensed' format name is the +# proper name. + +define IP_BUILTINS "|gif|giff\ + |sunras|ras\ + |xwd|x11|" + +define IP_GIF 1 # CompuServe GIF format +define IP_GIFF 2 # CompuServe GIF format +define IP_SUNRAS 3 # Sun Rasterfile +define IP_RAS 4 # Sun Rasterfile +define IP_XWD 5 # X11 Window Dump +define IP_X11 6 # X11 Window Dump + + + +# IP_PRBUILTIN -- Process a 'builtin' format. + +procedure ip_prbuiltin (ip, fname) + +pointer ip #i task struct pointer +char fname[ARB] #i file name + + +begin + # Branch off to the particular format. + switch (IP_FCODE(ip)) { + case IP_GIF, IP_GIFF: + call ip_gif (ip, fname, NO, NO) + case IP_SUNRAS, IP_RAS: + call ip_ras (ip, fname, NO, NO) + case IP_XWD, IP_X11: + call ip_xwd (ip, fname, NO, NO) + default: + return + } +end + + +# IP_BLTIN_INFO -- Process a 'builtin' format file information request. These +# are done separately because in a builtin we can print information such as +# colormap information, compression schemes, etc. + +procedure ip_bltin_info (ip, fname, verbose) + +pointer ip #i task struct pointer +char fname[ARB] #i file name +int verbose #i verbosity flag + +begin + # Branch off to the particular format. + switch (IP_FCODE(ip)) { + case IP_GIF, IP_GIFF: + call ip_gif (ip, fname, YES, verbose) + case IP_SUNRAS, IP_RAS: + call ip_ras (ip, fname, YES, verbose) + case IP_XWD, IP_X11: + call ip_xwd (ip, fname, YES, verbose) + default: + return + } +end + + +# IP_IS_BUILTIN -- See if this is a 'builtin' format. + +int procedure ip_is_builtin (format) + +char format[ARB] #i format to check + +int btoi(), strdic() + +begin + return (btoi(strdic(format,format,SZ_FNAME,IP_BUILTINS) != 0)) +end + + +# IP_FCODE -- Get the format code for a builtin format. + +int procedure ip_fcode (format) + +char format[ARB] #i format to check +int strdic() + +begin + return (strdic (format, format, SZ_FNAME, IP_BUILTINS)) +end diff --git a/pkg/dataio/import/ipdb.gx b/pkg/dataio/import/ipdb.gx new file mode 100644 index 00000000..9e4cb5c3 --- /dev/null +++ b/pkg/dataio/import/ipdb.gx @@ -0,0 +1,766 @@ +include +include +include +include +include "../import.h" +include "../ipfcn.h" + +define DEBUG false + + +# IP_EVAL_DBREC -- For each of the keywords defined in the database record, +# evaluate the expression and load the task structure. + +procedure ip_eval_dbrec (ip) + +pointer ip #i task struct pointer + +int ival +pointer sp, dims, pixtype, err +pointer np, stp, sym + +pointer stname(), sthead(), stnext +int or(), ip_dbgeti() +bool streq() + +errchk ip_dbgeti() + +begin + call smark (sp) + call salloc (dims, SZ_EXPR, TY_CHAR) + call salloc (pixtype, SZ_EXPR, TY_CHAR) + call salloc (err, SZ_EXPR, TY_CHAR) + call aclrc (Memc[dims], SZ_EXPR) + call aclrc (Memc[pixtype], SZ_EXPR) + call aclrc (Memc[err], SZ_EXPR) + + # Load the defaults. + call ip_load_defaults (ip) + + # First thing we do is get the byte swap flag so the remaining + # fields will be interpreted correctly. + ifnoerr (ival = ip_dbgeti (ip, "bswap")) + IP_SWAP(ip) = ival + + # Next, we handle 'interleave', 'dims' and 'pixtype' as a special case + # since for band- and line-interleaved files we may need to fix up the + # pixtype pointers. + ifnoerr (ival = ip_dbgeti (ip, "interleave")) + IP_INTERLEAVE(ip) = ival + + ifnoerr (call ip_dbstr (ip, "dims", Memc[dims], SZ_EXPR)) + call ip_do_dims (ip, Memc[dims]) + + ifnoerr (call ip_dbstr (ip, "pixtype", Memc[pixtype], SZ_EXPR)) { + if (Memc[pixtype] == '"') + call fdb_strip_quote (Memc[pixtype], Memc[pixtype], SZ_EXPR) + call ip_do_pixtype (ip, Memc[pixtype]) + } + + # Loop over every symbol in the table. + stp = IP_FSYM(ip) + for (sym=sthead(stp); sym != NULL; sym=stnext(stp,sym)) { + np = stname (stp, sym) + + if (streq(Memc[np],"format") || # ignored or found already + streq(Memc[np],"alias") || + streq(Memc[np],"image_id") || + streq(Memc[np],"interleave") || + streq(Memc[np],"dims") || + streq(Memc[np],"pixtype") || + streq(Memc[np],"id_string") || + streq(Memc[np],"bswap")) { + next + } else if (streq(Memc[np],"hskip")) { + IP_HSKIP(ip) = ip_dbgeti (ip, "hskip") + } else if (streq(Memc[np],"tskip")) { + IP_TSKIP(ip) = ip_dbgeti (ip, "tskip") + } else if (streq(Memc[np],"bskip")) { + IP_BSKIP(ip) = ip_dbgeti (ip, "bskip") + } else if (streq(Memc[np],"lskip")) { + IP_LSKIP(ip) = ip_dbgeti (ip, "lskip") + } else if (streq(Memc[np],"lpad")) { + IP_LPAD(ip) = ip_dbgeti (ip, "lpad") + } else if (streq(Memc[np],"yflip")) { + if (ip_dbgeti (ip, "yflip") == YES) + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_Y) + } else if (streq(Memc[np],"error")) { + if (IP_OUTPUT(ip) != IP_INFO) + call ip_do_error (ip, Memc[P2C(sym)]) + } else if (streq(Memc[np],"comment")) { + call fdb_strip_quote (Memc[P2C(sym)], Memc[P2C(sym)], SZ_LINE) + call ip_do_comment (ip, Memc[P2C(sym)]) + } else { + call eprintf ("Warning: Unknown database keyword '%s'.\n") + call pargstr (Memc[np]) + } + } + + if (DEBUG) { call zzi_prstruct ("eval dbrec:", ip) } + call sfree (sp) +end + + +# IP_LOAD_DEFAULTS -- Load the default input parameters to the task structure. + +procedure ip_load_defaults (ip) + +pointer ip #i task struct pointer + +begin + IP_SWAP(ip) = DEF_SWAP # type of byte swapping + IP_INTERLEAVE(ip) = DEF_INTERLEAVE # type of data interleaving + IP_HSKIP(ip) = DEF_HSKIP # bytes to skip before data + IP_TSKIP(ip) = DEF_TSKIP # bytes to skip after data + IP_BSKIP(ip) = DEF_BSKIP # bytes between image bands + IP_LSKIP(ip) = DEF_LSKIP # bytes to skip at front of + IP_LPAD(ip) = DEF_LPAD # bytes to skip at end of + + # zero image dimensions + for (IP_NDIM(ip)=IM_MAXDIM; IP_NDIM(ip) > 0; IP_NDIM(ip)=IP_NDIM(ip)-1) + IP_AXLEN(ip,IP_NDIM(ip)) = 0 +end + + +# IP_DBFCN -- Called by evvexpr to execute format database special functions. + +procedure ip_dbfcn (ip, fcn, args, nargs, o) + +pointer ip #i task struct pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf, outstr +int fd, func, v_nargs +int i, len, nchar, ival, cur_offset, swap +char ch +short sval +real rval +double dval + +short ip_getb(), ip_gets() +int strdic(), ip_line(), ip_locate(), ip_getu() +int ctoi(), ctol(), ctor(), ctod(), ctocc(), ctowrd() +int and(), strlen(), clgeti() +long ip_getl() +real ip_getr(), ip_getn() +double ip_getd(), ip_getn8() +bool strne(), streq() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (outstr, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[outstr], SZ_LINE) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, DB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case CTOCC, CTOD, CTOI, CTOL, CTOR, CTOWRD: + v_nargs = -1 + + case GETSTR: + v_nargs = -1 + case GETB, GETU, GETI, GETI2, GETI4, GETR, GETR4, GETR8, + GETN, GETN4, GETN8: + v_nargs = 1 + + case LOCATE: + v_nargs = -1 + case LINE, SKIP: + v_nargs = 1 + + case BSWAP: + v_nargs = 1 + case PARAMETER, DEFAULT: + v_nargs = 1 + case SUBSTR: + v_nargs = 3 + case STRIDX: + v_nargs = 2 + case LSB_HOST, MSB_HOST: + v_nargs = 0 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + fd = IP_FD(ip) + swap = IP_SWAP(ip) + cur_offset = IP_OFFSET(ip) + + if (DEBUG) { + call eprintf ("cur_offset=%d nargs=%d func=%s swap=%d\n") + call pargi(cur_offset) ; call pargi(nargs) + call pargstr(fcn) ; call pargi (swap) + do i = 1, nargs + call zzi_pevop (args[i]) + call eprintf ("init op => ") ; call zzi_pevop(o) + + } + + # Evaluate the function. + switch (func) { + case CTOCC: # run the fmtio equivalents of the argument + if (nargs == 1) + ch = ip_getb (fd, O_VALI(args[1])) + else + ch = ip_getb (fd, cur_offset) + len = ctocc (ch, Memc[outstr], SZ_FNAME) + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call amovc (Memc[outstr], O_VALC(o), len) + cur_offset = cur_offset + 1 + call ip_lseek (fd, cur_offset) + + case CTOWRD: + if (nargs == 1) + call ip_gstr (fd, O_VALI(args[1]), SZ_FNAME, Memc[outstr]) + else + call ip_gstr (fd, cur_offset, SZ_FNAME, Memc[outstr]) + nchar = ctowrd (Memc[outstr], i, Memc[outstr], SZ_FNAME) + 1 + call ip_initop (o, nchar, TY_CHAR) + call aclrc (O_VALC(o), nchar) + call amovc (Memc[outstr], O_VALC(o), nchar) + cur_offset = cur_offset + nchar + 1 + call ip_lseek (fd, cur_offset) + + case CTOI: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctoi (Memc[outstr], i, ival) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctoi (Memc[outstr], i, ival) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_INT + + case CTOL: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctol (Memc[outstr], i, ival) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctol (Memc[outstr], i, ival) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_LONG + + case CTOR: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctor (Memc[outstr], i, rval) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctor (Memc[outstr], i, rval) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_REAL + + case CTOD: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctod (Memc[outstr], i, dval) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctod (Memc[outstr], i, dval) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_DOUBLE + + case GETSTR: + if (nargs == 1) { + call ip_gstr (fd, cur_offset, O_VALI(args[1]), Memc[outstr]) + cur_offset = cur_offset + O_VALI(args[1]) + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + cur_offset = O_VALI(args[1]) + O_VALI(args[2]) - 1 + } + if (strlen(Memc[outstr]) == 0) { + len = strlen ("ERR") + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call strcpy ("ERR", O_VALC(o), len-1) + } else { + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call amovc (Memc[outstr], O_VALC(o), len-1) + } + + case GETB: + if (nargs == 0) { + sval = ip_getb (fd, cur_offset) + cur_offset = cur_offset + SZB_CHAR + } else { + sval = ip_getb (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + SZB_CHAR + } + ival = sval + O_TYPE(o) = TY_INT + + case GETU: + if (nargs == 0) { + sval = short (ip_getu (fd, cur_offset)) + cur_offset = cur_offset + (SZB_CHAR * SZ_SHORT) + } else { + sval = short (ip_getu (fd, O_VALI(args[1]))) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_SHORT) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) + call bswap2 (sval, 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + ival = sval + O_TYPE(o) = TY_INT + + case GETI, GETI2: + if (nargs == 0) { + sval = ip_gets (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_SHORT) + } else { + sval = ip_gets (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_SHORT) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) + call bswap2 (sval, 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + ival = sval + O_TYPE(o) = TY_INT + + case GETI4: + if (nargs == 0) { + ival = ip_getl (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_LONG) + } else { + ival = ip_getl (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_LONG) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) + call bswap4 (ival, 1, ival, 1, (SZ_INT32*SZB_CHAR)) + O_TYPE(o) = TY_INT + + case GETR, GETR4: + if (nargs == 0) { + rval = ip_getr (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_REAL) + } else { + rval = ip_getr (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_REAL) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap4 (rval, 1, rval, 1, (SZ_REAL*SZB_CHAR)) + O_TYPE(o) = TY_REAL + + case GETR8: + if (nargs == 0) { + dval = ip_getd (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_DOUBLE) + } else { + dval = ip_getd (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_DOUBLE) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap8 (dval, 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + O_TYPE(o) = TY_DOUBLE + + case GETN, GETN4: + if (nargs == 0) { + rval = ip_getn (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_REAL) + } else { + rval = ip_getn (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_REAL) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap4 (rval, 1, rval, 1, (SZ_REAL*SZB_CHAR)) + O_TYPE(o) = TY_REAL + + case GETN8: + if (nargs == 0) { + dval = ip_getn8 (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_DOUBLE) + } else { + dval = ip_getn8 (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_DOUBLE) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap8 (dval, 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + O_TYPE(o) = TY_DOUBLE + + case LOCATE: # locate the pattern in the file + if (nargs == 1) + ival = ip_locate (fd, cur_offset, O_VALC(args[1])) + else if (nargs == 2) + ival = ip_locate (fd, O_VALI(args[1]), O_VALC(args[2])) + if (ival == ERR) + ival = 1 + O_TYPE(o) = TY_INT + cur_offset = ival + + case LINE: # locate the line no. in the file + ival = ip_line (fd, O_VALI(args[1])) + if (ival == ERR) + ival = 1 + O_TYPE(o) = TY_INT + cur_offset = ival + + case SKIP: # skip a certain number of bytes + ival = O_VALI(args[1]) + O_TYPE(o) = TY_INT + cur_offset = cur_offset + ival + + case BSWAP: # byte-swap argument + O_TYPE(o) = O_TYPE(args[1]) + switch (O_TYPE(args[1])) { + case TY_SHORT: + call bswap2 (O_VALS(args[1]), 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + case TY_INT: + call bswap4 (O_VALI(args[1]), 1, ival, 1, (SZ_INT32*SZB_CHAR)) + case TY_LONG: + call bswap4 (O_VALL(args[1]), 1, ival, 1, (SZ_LONG*SZB_CHAR)) + case TY_REAL: + call bswap4 (O_VALR(args[1]), 1, rval, 1, (SZ_REAL*SZB_CHAR)) + case TY_DOUBLE: + call bswap8 (O_VALD(args[1]), 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + } + + case PARAMETER: # return current task parameter value + if (streq(O_VALC(args[1]),"dims")) { + call clgstr ("dims", Memc[outstr], SZ_FNAME) + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call strcpy (Memc[outstr], O_VALC(o), len) + } else if (streq(O_VALC(args[1]),"pixtype")) { + call clgstr ("pixtype", Memc[outstr], SZ_FNAME) + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call strcpy (Memc[outstr], O_VALC(o), len) + } else if (streq(O_VALC(args[1]),"interleave")) { + ival = clgeti ("interleave") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bswap")) { + call clgstr ("bswap", Memc[outstr], SZ_FNAME) + if (strne("no",Memc[outstr]) && strne("none",Memc[outstr])) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + } else if (streq(O_VALC(args[1]),"hskip")) { + ival = clgeti ("hskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"tskip")) { + ival = clgeti ("tskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bskip")) { + ival = clgeti ("bskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lskip")) { + ival = clgeti ("lskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lpad")) { + ival = clgeti ("lpad") + O_TYPE(o) = TY_INT + } + + case DEFAULT: # return default task parameter value + if (streq(O_VALC(args[1]),"dims")) { + call ip_initop (o, 1, TY_CHAR) + call strcpy ("", O_VALC(o), 1) + } else if (streq(O_VALC(args[1]),"pixtype")) { + call ip_initop (o, 1, TY_CHAR) + call strcpy ("", O_VALC(o), 1) + } else if (streq(O_VALC(args[1]),"interleave")) { + ival = DEF_INTERLEAVE + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bswap")) { + ival = DEF_SWAP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"hskip")) { + ival = DEF_HSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"tskip")) { + ival = DEF_TSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bskip")) { + ival = DEF_BSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lskip")) { + ival = DEF_LSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lpad")) { + ival = DEF_LPAD + O_TYPE(o) = TY_INT + } + + case LSB_HOST: # host is an LSB byte ordered machine + if (BYTE_SWAP2 == YES) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + + case MSB_HOST: # host is an MSB byte ordered machine + if (BYTE_SWAP2 == NO) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + + case SUBSTR: # return a substring of the argument + + case STRIDX: # return offset of a char w/in str + + } + + # Write result to output operand. + O_LEN(o) = 0 + switch (O_TYPE(o)) { + case TY_USHORT, TY_SHORT: + O_VALS(o) = sval + case TY_INT, TY_BOOL: + O_VALI(o) = ival + case TY_LONG: + O_VALL(o) = ival + case TY_REAL: + O_VALR(o) = rval + case TY_DOUBLE: + O_VALD(o) = dval + } + + if (DEBUG) { call eprintf("ip_dbfcn: ") ; call zzi_pevop (o) } + + IP_OFFSET(ip) = cur_offset + call sfree (sp) +end + + +# IP_DBSTR -- Get a string valued expression from the database. + +procedure ip_dbstr (ip, param, outstr, maxch) + +pointer ip #i task struct pointer +char param[ARB] #i parameter to evaluate +char outstr[ARB] #o result string +int maxch #i max length of string + +pointer sp, expr, o + +int locpr(), strlen() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + call aclrc (Memc[expr], SZ_EXPR) + + # Get the requested parameter. + call aclrc (outstr, SZ_EXPR) + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "FDBGET: Format parameter not found") + + if (DEBUG) { + call eprintf("ip_dbstr: expr='%s' len=%d ");call pargstr(Memc[expr]) + call pargi(strlen(Memc[expr])) + } + + # Evaluate the expression. + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) != TY_CHAR) + call error (0, "ip_dbstr: Expression must be a string valued") + else + call amovc (O_VALC(o), outstr, (min(strlen(O_VALC(o)),maxch))) + } then + call erract (EA_WARN) + + if (DEBUG) { call eprintf ("outstr=:%s:\n") ; call pargstr (outstr) } + + call evvfree (o) + call sfree (sp) +end + +$for (ir) + +$if (datatype == i) +# IP_DBGETI -- Get integer valued format parameter from the database. +$else +# IP_DBGETR -- Get real valued format parameter from the database. +$endif + +PIXEL procedure ip_dbget$t (ip, param) + +pointer ip #i task struct pointer +char param[ARB] #i requested parameter + +PIXEL val +pointer sp, expr, o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + + # Get the requested parameter. + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "IP_DBGET: Format parameter not found") + + # Evaluate the expression. + if (DEBUG) { + call eprintf ("ip_dbget: expr='%s'\n") + call pargstr (Memc[expr]) + call flush (STDERR) + } + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) == TY_BOOL) { + val = O_VALI(o) + $if (datatype == i) + } else if (O_TYPE(o) != TY_PIXEL && O_TYPE(o) != TY_SHORT) { + call error (0, "Expression must be an integer") + $else + } else if (O_TYPE(o) != TY_PIXEL) { + call error (0, "Expression must be a real") + $endif + } else + val = O_VAL$T(o) + + if (DEBUG) { + call eprintf ("ip_dbget: val=%d type=%d ecpr=:%s:\n") + call parg$t (val) + call pargi (O_TYPE(o)) + call pargstr (Memc[expr]) + call flush (STDERR) + } + } then + call erract (EA_WARN) + + call evvfree (o) + call sfree (sp) + return (val) +end +$endfor + +# IP_DO_ERROR -- Process the error parameter. + +procedure ip_do_error (ip, expr) + +pointer ip #i task struct pointer +char expr[ARB] #i error string + +pointer o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +bool strne() +errchk evvexpr + +begin + if (DEBUG) {call eprintf ("error expr: '%s' ") ; call pargstr (expr)} + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ip_getop), ip, locpr(ip_dbfcn), ip, + EV_RNGCHK) + + if (DEBUG) { call eprintf("-> '%s'\n") ; call pargstr(O_VALC(o)) } + + if (O_TYPE(o) != TY_CHAR) + call error (2, "do_error: Expression must be a string valued") + else { + if (strne("okay",O_VALC(o))) + call error (2, O_VALC(o)) + } + call evvfree (o) + + } then + if (IP_OUTPUT(ip) != IP_INFO) + call erract (EA_FATAL) +end + + +# IP_DO_COMMENT - Process a comment line in the format database. + +procedure ip_do_comment (ip, comstr) + +pointer ip #i task struct pointer +char comstr[ARB] #i comment to add + +pointer sp, buf + +begin + # Copy the comment line to the comment block. + if (IP_COMPTR(ip) == NULL) + call calloc (IP_COMPTR(ip), SZ_COMMENT, TY_CHAR) + + if (COMMENT(ip) == '\0') { + call strcpy ("\t", COMMENT(ip), SZ_LINE) + call strcat (comstr, COMMENT(ip), SZ_LINE) + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + Memc[buf] = '\0' + call strcpy ("\t", Memc[buf], SZ_LINE) + call strcat (comstr, Memc[buf], SZ_LINE) + call strcat ("\n", Memc[buf], SZ_LINE) + call strcat (COMMENT(ip), Memc[buf], SZ_COMMENT) + + call strcpy (Memc[buf], COMMENT(ip), SZ_COMMENT) + + call sfree (sp) + } +end + + +# IP_INITOP - Initialize an operand pointer to the requested values + +procedure ip_initop (o, len, type) + +pointer o #u operand pointer +int len #i length of array +int type #i data type of operand + +begin + O_LEN(o) = len + O_TYPE(o) = type + if (len > 1) + call calloc (O_VALP(o), len, type) +end diff --git a/pkg/dataio/import/ipfcn.h b/pkg/dataio/import/ipfcn.h new file mode 100644 index 00000000..090c040e --- /dev/null +++ b/pkg/dataio/import/ipfcn.h @@ -0,0 +1,57 @@ +# IPFCN.H - Include file for the special functions supported by the IMPORT task. + +# Format database functions. +define DB_FUNCTIONS "|ctocc|ctod|ctoi|ctol|ctor|ctowrd|\ + |getstr|getb|getu|geti|geti2|geti4|\ + |getr|getr4|getr8|getn|getn4|getn8|\ + |locate|line|skip|bswap|parameter|default|\ + |lsb_host|msb_host|substr|stridx|" + +define CTOCC 1 # Convert character to printable char constant +define CTOD 2 # Convert string to double precision real +define CTOI 3 # Convert string to integer +define CTOL 4 # Convert string to long +define CTOR 5 # Convert string to single precision real +define CTOWRD 6 # Return 1st white-space delimited word from str +# newline +define GETSTR 8 # Get a string at offset +define GETB 9 # Get a byte at offset +define GETU 10 # Get an unsigned short int at offset +define GETI 11 # Get a signed int at offset +define GETI2 12 # Get a signed int at offset +define GETI4 13 # Get a long signed int at offset +# newline +define GETR 15 # Get an IEEE fp number at offset +define GETR4 16 # Get an IEEE fp number at offset +define GETR8 17 # Get an IEEE double precision number at offset +define GETN 18 # Get a native fp number at offset +define GETN4 19 # Get a native fp number at offset +define GETN8 20 # Get a native double precision number at offset +# newline +define LOCATE 22 # Compute an offset +define LINE 23 # Offset of line N +define SKIP 24 # Move offset N-bytes +define BSWAP 25 # Byte swap the argument +define PARAMETER 26 # Return current task parameter +define DEFAULT 27 # Return default task parameter +# newline +define LSB_HOST 29 # Host is LSB byte ordered machine +define MSB_HOST 30 # Host is MSB byte ordered machine +define SUBSTR 31 # Return a substring of the argument +define STRIDX 32 # Return occurance of a char within a string + + +# Outbands expression functions. +define OB_FUNCTIONS "|gray|grey|flipx|flipy|\ + |red|green|blue|" + +define GRAY 1 # Convert to NTSC grayscale +define GREY 2 # Convert to NTSC grayscale (alias) +define FLIPX 3 # Flip image in X +define FLIPY 4 # Flip image in Y +# newline +define RED 6 # Get red component of colormap image +define GREEN 7 # Get green component of colormap image +define BLUE 8 # Get blue component of colormap image + + diff --git a/pkg/dataio/import/ipfio.gx b/pkg/dataio/import/ipfio.gx new file mode 100644 index 00000000..61147ea2 --- /dev/null +++ b/pkg/dataio/import/ipfio.gx @@ -0,0 +1,443 @@ +include +include +include "../import.h" + +define DEBUG false + + +# IP_GSTR -- Get a string of the specifed length from the given offset. + +procedure ip_gstr (fd, offset, len, outstr) + +int fd +int offset +int len +char outstr[ARB] + +int nstat, read() +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, len+2, TY_CHAR) + call aclrc (Memc[buf], len+2) + call aclrc (outstr, len+2) + + call ip_lseek (fd, offset) + nstat = read (fd, Memc[buf], len) + + if (mod(offset,2) == 0 && offset > 1) + call bytmov (Memc[buf], 2, Memc[buf], 1, len) + call chrupk (Memc[buf], 1, outstr, 1, len) + + if (DEBUG) { call eprintf ("ip_gstr: :%s: len=%d\n"); + call pargstr(outstr) ; call pargi (len) } + call sfree (sp) +end + + +# IP_GETB -- Get a byte from the given offset. + +short procedure ip_getb (fd, offset) + +int fd +int offset + +int nstat, read() +short val +char buf[2] + +begin + call ip_lseek (fd, offset) + nstat = read (fd, buf, 2) + + if (mod(offset,2) == 0) + call bytmov (buf, 2, buf, 1, 2) + call chrupk (buf, 1, buf, 1, 2) + + if (DEBUG) { call eprintf ("ip_getb: %d\n"); call pargs(buf[1]) } + if (buf[1] < 0) + val = buf[1] + 256 + else + val = buf[1] + return (val) +end + + +# IP_GETU -- Get a unsigned short integer from the given offset. + +int procedure ip_getu (fd, offset) + +int fd +int offset + +int val +short ip_gets() + +begin + val = ip_gets (fd, offset) + if (val < 0) + val = val + 65536 + return (val) +end + +# IP_GET[silrd] -- Get a value of from the given offset. + +$for (silrd) + +PIXEL procedure ip_get$t (fd, offset) + +int fd +int offset + +int nstat, read() +PIXEL val + +begin + call ip_lseek (fd, offset) + $if (datatype == il) + nstat = read (fd, val, SZ_INT32 * SZB_CHAR) + if (SZ_INT != SZ_INT32) + call iupk32 (val, val, 1) + $else + nstat = read (fd, val, SZ_PIXEL * SZB_CHAR) + $endif + $if (datatype == rd) + call ieeupk$t (val) + $endif + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call parg$t(val) } + return (val) +end +$endfor + +# IP_GETN -- Get a native floating point number from the given offset. + +real procedure ip_getn (fd, offset) + +int fd +int offset + +int nstat, read() +real rval + +begin + call ip_lseek (fd, offset) + nstat = read (fd, rval, SZ_REAL) + + if (DEBUG) { call eprintf ("ip_getn: %g\n"); call pargr(rval) } + return (rval) +end + + +# IP_GETN8 -- Get a native double precision floating point number from the +# given offset. + +double procedure ip_getn8 (fd, offset) + +int fd +int offset + +int nstat, read() +double dval + +begin + call ip_lseek (fd, offset) + nstat = read (fd, dval, SZ_DOUBLE) + + if (DEBUG) { call eprintf ("ip_getn8: %g\n"); call pargd(dval) } + return (dval) +end + + +# IP_AGETB -- Get an array of bytes from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetb (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +pointer sp, buf +int fp, nval, nstat +int ip_lnote(), read() + +begin + fp = ip_lnote(fd) + if (mod(fp,2) == 0 && fp != 1) + nval = len + else + nval = len + 1 + + call smark (sp) + call salloc (buf, nval, TY_CHAR) + + if (ptr == NULL) + call malloc (ptr, nval * SZB_CHAR, TY_CHAR) + nstat = read (fd, Memc[buf], nval / SZB_CHAR + 1) + + fp = ip_lnote(fd) + if (mod(fp,2) == 0 && fp != 1) + call bytmov (Memc[buf], 2, Memc[buf], 1, nval) + call achtbc (Memc[buf], Memc[ptr], len) + + call sfree (sp) +end + + +# IP_AGETU -- Get an array of from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetu (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +begin + call ip_agets (fd, ptr, len) + call achtsu (Mems[ptr], Mems[ptr], len) +end + + +# IP_AGET[silrd] -- Get an array of from the file. The data pointer is +# allocated if necessary and contains the data on output. + +$for (silrd) +procedure ip_aget$t (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_PIXEL) + $if (datatype == il) + nstat = read (fd, Mem$t[ptr], len * SZ_INT32) + if (SZ_INT != SZ_INT32) + call iupk32 (Mem$t[ptr], Mem$t[ptr], len) + $else + nstat = read (fd, Mem$t[ptr], len * SZ_PIXEL) + $endif + $if (datatype == rd) + call ieevupk$t (Mem$t[ptr], Mem$t[ptr], len) + $endif +end + +$endfor + +# IP_AGETN -- Get an array of native floats from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetn (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_REAL) + nstat = read (fd, Memr[ptr], len * SZ_REAL) +end + + +# IP_AGETN8 -- Get an array of native doubles from the file. The data pointer +# is allocated if necessary and contains the data on output. + +procedure ip_agetn8 (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_DOUBLE) + nstat = read (fd, Memd[ptr], len * SZ_DOUBLE) +end + + +# ----------------------------------------------------------------- +# ------------------ UTILITY FILE I/O FUNCTIONS ------------------- +# ----------------------------------------------------------------- + + +define BLKSIZE 1024 + +# IP_LINE -- Return the offset of the start of the given line number. + +int procedure ip_line (fd, line) + +int fd #i input file descriptor +int line #i line number to search + +pointer sp, cbuf, buf +int nl, offset, i, nread, fsize + +int read(), fstati() + +define done_ 99 +define err_ 98 + +begin + if (line == 1) { + return (1) + } else { + call smark (sp) + call salloc (buf, BLKSIZE, TY_CHAR) + call salloc (cbuf, BLKSIZE, TY_CHAR) + + # Rewind file descriptor + call ip_lseek (fd, BOF) + nl = 1 + offset = 1 + + nread = BLKSIZE / SZB_CHAR + fsize = fstati (fd, F_FILESIZE) + while (read (fd, Memc[buf], nread) != EOF) { + # Convert it to spp chars. + call ip_lskip (fd, nread) + call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE) + do i = 1, BLKSIZE { + if (Memc[cbuf+i-1] == '\n') { + nl = nl + 1 + offset = offset + 1 + if (nl == line) + goto done_ + } else + offset = offset + 1 + if (offset >= fsize) + goto err_ + } + } +err_ call sfree (sp) + call ip_lseek (fd, BOF) + return (ERR) + +done_ if (DEBUG) { call eprintf("ip_line: '%s'\n"); call pargi(offset) } + call sfree (sp) + call ip_lseek (fd, offset) + return (offset) + } +end + + +# IP_LOCATE -- Return the offset of the start of the given pattern. + +int procedure ip_locate (fd, offset, pattern) + +int fd #i input file descriptor +int offset #i offset to begin search +char pattern[ARB] #i pattern to locate + +pointer sp, cbuf, buf +int fsize, nread, patlen, cur_offset, loc + +int fstati(), read(), strsearch(), strlen() + +define done_ 99 + +begin + # Rewind file descriptor + call ip_lseek (fd, offset) + cur_offset = offset + + call smark (sp) + call salloc (buf, BLKSIZE, TY_CHAR) + call salloc (cbuf, BLKSIZE, TY_CHAR) + + if (DEBUG) { call eprintf("ip_loc: offset %d\n"); call pargi(offset)} + + nread = BLKSIZE / SZB_CHAR + fsize = fstati (fd, F_FILESIZE) + patlen = strlen (pattern) + while (read (fd, Memc[buf], nread) != EOF) { + # Convert it to spp chars. + call ip_lskip (fd, nread) + call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE) + loc = strsearch (Memc[cbuf], pattern) + if (loc != 0) { + cur_offset = cur_offset + loc - 1 - patlen + goto done_ + } else { + # Allow some overlap in case the pattern broke over the blocks. + cur_offset = cur_offset + BLKSIZE - 2 * patlen + call ip_lseek (fd, cur_offset) + if (cur_offset + BLKSIZE > fsize) + nread = fsize - cur_offset + 1 + } + } + call sfree (sp) + call ip_lseek (fd, BOF) + return (ERR) + +done_ if (DEBUG) { call eprintf("ip_loc: %d\n"); call pargi(cur_offset)} + call sfree (sp) + call ip_lseek (fd, offset) + return (cur_offset) +end + + +# IP_LSEEK -- Set the file position as a byte offset. + +procedure ip_lseek (fd, offset) + +int fd #i file descriptor +int offset #i requested offset + +long cur_offset, where, fsize +int fstati() +common /fiocom/ cur_offset + +begin + if (offset == BOF || offset == ERR) { + cur_offset = 1 + call seek (fd, BOF) + } else { + fsize = fstati (fd, F_FILESIZE) * SZB_CHAR + cur_offset = min (fsize, offset) + where = min (fsize, (offset/SZB_CHAR+mod(offset,2))) + call seek (fd, where) + } +end + + +# IP_LNOTE -- Note the file position as a byte offset. + +int procedure ip_lnote (fd) + +int fd #i file descriptor (unused) + +long cur_offset +common /fiocom/ cur_offset + +begin + return (cur_offset) +end + + +# IP_LSKIP -- Bump the file position by a byte offset. + +procedure ip_lskip (fd, skip) + +int fd #i file descriptor +int skip + +long cur_offset +common /fiocom/ cur_offset + +begin + call ip_lseek (fd, cur_offset+skip) +end diff --git a/pkg/dataio/import/ipinfo.x b/pkg/dataio/import/ipinfo.x new file mode 100644 index 00000000..3ded4a2d --- /dev/null +++ b/pkg/dataio/import/ipinfo.x @@ -0,0 +1,256 @@ +include "import.h" + + +# IP_INFO -- Print information about the binary file. + +procedure ip_info (ip, fname, verbose) + +pointer ip #i task struct pointer +char fname[ARB] #i binary file name +int verbose #i verbose output? + +pointer sp, buf +pointer fmt +int fdb +int locpr(), fdb_opendb() + +pointer fdb_scan_records() +extern ip_getop(), ip_dbfcn() + +begin + if (IP_BLTIN(ip) == YES) { + call ip_bltin_info (ip, fname, verbose) + + } else if (IP_FORMAT(ip) == IP_NONE) { + call ip_prinfo (ip, "User Specified Format", fname, verbose) + + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + if (IP_FSYM(ip) == NULL) { + fdb = fdb_opendb () + fmt = fdb_scan_records (fdb, "image_id", + locpr(ip_getop), ip, locpr(ip_dbfcn), ip) + call fdbgstr (fmt, "id_string", Memc[buf], SZ_LINE) + call fdb_strip_quote (Memc[buf], Memc[buf], SZ_EXPR) + call ip_prinfo (ip, Memc[buf], fname, verbose) + call fdb_close (fmt) + call fdb_closedb (fdb) + } else { + call fdbgstr (IP_FSYM(ip), "id_string", Memc[buf], SZ_LINE) + call fdb_strip_quote (Memc[buf], Memc[buf], SZ_EXPR) + call ip_prinfo (ip, Memc[buf], fname, verbose) + } + + call sfree (sp) + } +end + + +# IP_PRINFO -- Print information about the binary file. + +procedure ip_prinfo (ip, format, fname, verbose) + +pointer ip #i task struct pointer +char format #i format name +char fname[ARB] #i binary file name +int verbose #i verbose output? + +int i +bool itob() + +define done_ 99 + +begin + #call printf ("Input file:\n\t") + if (verbose == NO) { + call printf ("%s: %20t") + call pargstr (fname) + do i = 1, IP_NDIM(ip) { + call printf ("%d ") + call pargi (IP_AXLEN(ip,i)) + if (i < IP_NDIM(ip)) + call printf ("x ") + } + call printf (" \t%s\n") + call pargstr (format) + + # Print out the format comment if any. +# if (IP_COMPTR(ip) != NULL) { +# if (COMMENT(ip) != '\0') { +# call printf ("%s\n") +# call pargstr (COMMENT(ip)) +# } +# call strcpy ("\0", COMMENT(ip), SZ_LINE) +# } + return + } + + # Print a more verbose description. + call printf ("%s: %20t%s\n") + call pargstr (fname) + call pargstr (format) + + # Print out the format comment if any. + if (IP_COMPTR(ip) != NULL) { + if (COMMENT(ip) != '\0') { + call printf ("%s\n") + call pargstr (COMMENT(ip)) + } + call strcpy ("\0", COMMENT(ip), SZ_LINE) + } + + # Print the image size. + if (IP_NDIM(ip) > 0) { + call printf ("%20tResolution:%38t") + do i = 1, IP_NDIM(ip) { + call printf ("%d ") + call pargi (IP_AXLEN(ip,i)) + if (i < IP_NDIM(ip)) + call printf ("x ") + } + call printf ("\n") + } + + # Print other information. + if (PTYPE(ip,1) != NULL) { + call printf ("%20tPixel type: %38t%d-bit ") + call pargi (8 * IO_NBYTES(PTYPE(ip,1))) + switch (IO_TYPE(PTYPE(ip,1))) { + case PT_UINT: + call printf ("unsigned integer\n") + case PT_INT: + call printf ("signed integer\n") + case PT_IEEE: + call printf ("IEEE floating point\n") + case PT_NATIVE: + call printf ("native floating point\n") + default: + call printf ("\n") + } + } + + call printf ("%20tPixel storage: %38t%s\n") + if (BAND_INTERLEAVED(ip)) + call pargstr ("non-interleaved") + else if (LINE_INTERLEAVED(ip)) + call pargstr ("line-interleaved") + else if (PIXEL_INTERLEAVED(ip)) + call pargstr ("pixel-interleaved") + else + call pargstr ("unknown") + call printf ("%20tHeader length: %38t%d bytes\n") + call pargi (IP_HSKIP(ip)) + call printf ("%20tByte swapped: %38t%b\n") + call pargb (itob(IP_SWAP(ip))) +end + + +# IP_OBINFO - Print information about the output image contents. + +procedure ip_obinfo (ip, imname) + +pointer ip #i ip struct pointer +char imname[ARB] #i image name + +int i, nb + +begin + call printf (" Output image:\n") + + if (IP_NBANDS(ip) != ERR) { + nb = IP_NBANDS(ip) + do i = 1, nb { + call printf ("\t%s[*,*,%d]:%30t==> %s %s\n") + call pargstr (imname) + call pargi (i) + call pargstr (O_EXPR(ip,i)) + if (i == 1) + call pargstr (" # outbands expr") + else + call pargstr (" ") + } + } else { + nb = max (IP_AXLEN(ip,3), max (IP_INTERLEAVE(ip), IP_NPIXT(ip))) + do i = 1, nb { + call printf ("\t%s[*,*,%d]:%30t==> %s%d %s\n") + call pargstr (imname) + call pargi (i) + call pargstr ("b") + call pargi (i) + if (i == 1) + call pargstr (" # outbands expr") + else + call pargstr (" ") + } + } + +end + + +# IP_LIST_FORMATS -- List the formats in the database. The DB is scanned +# and the format name for each record found, as well as the verbose ID +# string is printed on the standard output. The file position is left at +# the same place on exit. + +procedure ip_list_formats (fd) + +int fd #i input binary file descriptor + +pointer sp, format, idstr, alias +pointer fmt, ap[5] +int i, nsym, cur_offset + +int note() +pointer stfindall(), fdb_next_rec() + +begin + # Save current file offset. + cur_offset = note (fd) + + call smark (sp) + call salloc (format, SZ_EXPR, TY_CHAR) + call salloc (idstr, SZ_EXPR, TY_CHAR) + call salloc (alias, SZ_LINE, TY_CHAR) + + # Loop through the database records. + call seek (fd, BOF) + fmt = NULL + call printf ("Format%15tAliases%36tFormat Identification\n") + call printf ("------%15t-------%36t---------------------\n") + repeat { + fmt = fdb_next_rec (fd) + if (fmt == NULL) + break + call fdbgstr (fmt, "format", Memc[format], SZ_EXPR) + call fdbgstr (fmt, "id_string", Memc[idstr], SZ_EXPR) + call fdb_strip_quote (Memc[idstr], Memc[idstr], SZ_EXPR) + + # Generate a list of aliases for the format. + call aclrc (Memc[alias], SZ_LINE) + nsym = stfindall (fmt, "alias", ap, 5) + if (nsym >= 1) { + do i = nsym, 1, -1 { + call strcat (Memc[P2C(ap[i])], Memc[alias], SZ_LINE) + if (i > 1) + call strcat (",", Memc[alias], SZ_LINE) + } + } else + Memc[alias] = EOS + + # Print the information + call printf ("%s%15t%.20s%36t%s\n") + call pargstr (Memc[format]) + call pargstr (Memc[alias]) + call pargstr (Memc[idstr]) + + call fdb_close (fmt) + call flush (STDOUT) + } + + # Restore file offset. + call seek (fd, cur_offset) + + call sfree (sp) +end diff --git a/pkg/dataio/import/iplistpix.x b/pkg/dataio/import/iplistpix.x new file mode 100644 index 00000000..3f4a001d --- /dev/null +++ b/pkg/dataio/import/iplistpix.x @@ -0,0 +1,137 @@ +include +include +include + +# IP_LISTPIXELS -- Convert image pixels into a text stream, i.e., into a list. +# Each pixel is printed on a separate line, preceded by its coordinates. + +procedure ip_listpix (im) + +char wcs[SZ_FNAME] +double incoords[IM_MAXDIM], outcoords[IM_MAXDIM] +int i, j, npix, ndim, wcsndim, laxis1, fmtstat +int paxno[IM_MAXDIM], laxno[IM_MAXDIM] +long v[IM_MAXDIM], vcoords[IM_MAXDIM] +pointer im, line, mw, ct, fmtptrs[IM_MAXDIM] + +int imgnlr(), mw_stati() +pointer mw_openim(), mw_sctran() + +begin + # Get info from the input image. + ndim = IM_NDIM(im) + npix = IM_LEN(im,1) + + # Get the wcs. + call strcpy ("world", wcs, SZ_FNAME) + ifnoerr (mw = mw_openim (im)) { + # Set up the transformation. + call mw_seti (mw, MW_USEAXMAP, NO) + ct = mw_sctran (mw, "logical", wcs, 0) + wcsndim = mw_stati (mw, MW_NPHYSDIM) + + # Get the physical to logical axis map. + call mw_gaxmap (mw, paxno, laxno, wcsndim) + + # Set the default wcs. + call mw_ssytem (mw, wcs) + + } else { + # Print the error message from the above loop. + call erract (EA_WARN) + + # Set the transform to the identity transform. + mw = NULL + ct = NULL + wcsndim = ndim + + # Set the default physical to logical axis map. + do i = 1, wcsndim + paxno[i] = i + } + + # Initialize the v vectors. + call amovkl (long (1), v, IM_MAXDIM) + call amovkl (long (1), vcoords, IM_MAXDIM) + + # Initialize the coordinates. + laxis1 = 0 + do i = 1, wcsndim { + if (paxno[i] == 0) { + incoords[i] = 1 + } else if (paxno[i] == 1) { + laxis1 = i + incoords[i] = v[1] + } else { + incoords[i] = v[paxno[i]] + } + } + + # Check and correct for the no axis mapping case. + if (laxis1 == 0) { + laxis1 = 1 + do i = 1, wcsndim + paxno[i] = i + } + + # Get the logical to physical axis map for the format strings. + do i = 1, ndim { + laxno[i] = 0 + do j = 1, wcsndim { + if (paxno[j] != i) + next + laxno[i] = j + break + } + } + + # Set the format strings for the logical axes. + fmtstat = EOS + do i = 1, ndim { + call malloc (fmtptrs[i], SZ_FNAME, TY_CHAR) + if (fmtstat != EOF) + call gargwrd (Memc[fmtptrs[i]], SZ_FNAME) + else + Memc[fmtptrs[i]] = EOS + if (laxno[i] == 0) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else if (mw == NULL || ct == NULL) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else iferr (call mw_gwattrs (mw, laxno[i], "format", + Memc[fmtptrs[i]], SZ_FNAME)) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else + call strcat (" ", Memc[fmtptrs[i]], SZ_FNAME) + } + + # Print the pixels. + while (imgnlr (im, line, v) != EOF) { + do i = 1, npix { + incoords[laxis1] = i + if (ct == NULL) + call amovd (incoords, outcoords, wcsndim) + else + call mw_ctrand (ct, incoords, outcoords, wcsndim) + do j = 1, ndim { # X, Y, Z, etc. + call printf (Memc[fmtptrs[j]]) + if (laxno[j] == 0) + call pargd (double(vcoords[j])) + else + call pargd (outcoords[laxno[j]]) + } + call printf (" %g\n") # pixel value + call pargr (Memr[line+i-1]) + } + call amovl (v, vcoords, IM_MAXDIM) + do i = 1, wcsndim { + if (paxno[i] == 0) + next + incoords[i] = v[paxno[i]] + } + } + + do i = 1, ndim + call mfree (fmtptrs[i], TY_CHAR) + if (mw != NULL) + call mw_close (mw) +end diff --git a/pkg/dataio/import/ipmkhdr.x b/pkg/dataio/import/ipmkhdr.x new file mode 100644 index 00000000..c8432ed2 --- /dev/null +++ b/pkg/dataio/import/ipmkhdr.x @@ -0,0 +1,63 @@ +include +include +include "import.h" + +define LEN_COMMENT 70 # Maximum comment length +define COMMENT "COMMENT " # Comment key +define IS_FITS (IS_DIGIT($1)||IS_UPPER($1)||($1=='-')||($1=='_')) + +# IP_MKHEADER -- Append or substitute new image header from an image or file. +# Only the legal FITS cards (ignoring leading whitespace) will be copied +# from a file. + +procedure ip_mkheader (im, fname) + +pointer im # IMIO pointer +char fname[ARB] # Image or data file name + +int i, j +pointer ua, fd +pointer sp, str + +int open(), getline(), nowhite() +pointer immap() +errchk open + +begin + if (nowhite (fname, fname, SZ_FNAME) == 0) + return + + ua = IM_USERAREA(im) + ifnoerr (fd = immap (fname, READ_ONLY, LEN_UA)) { + call strcpy (Memc[IM_USERAREA(fd)], Memc[ua], LEN_UA) + call imunmap (fd) + } else { + fd = open (fname, READ_ONLY, TEXT_FILE) + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + Memc[ua] = EOS + while (getline (fd, Memc[str]) != EOF) { + for (i=str; IS_WHITE(Memc[i]); i=i+1) + ; + for (j=i; IS_FITS(Memc[j]); j=j+1) + ; + for (; j +include +include +include +include "../import.h" +include "../ipfcn.h" + +define DEBUG false +define VDEBUG false + + +# IP_GETOP -- Called by evvexpr to get an operand. + +procedure ip_getop (ip, opname, o) + +pointer ip #i task struct pointer +char opname[ARB] #i operand name to retrieve +pointer o #o output operand pointer + +int i, nops, found, optype +pointer sp, buf +pointer op + +int fstati(), ip_ptype(), strlen(), strncmp() +bool streq() + +begin + # First see if it's one of the special file operands. + if (opname[1] == '$') { + if (strncmp(opname, "$FSIZE", 3) == 0) { + O_LEN(o) = 0 + O_TYPE(o) = TY_INT + O_VALI(o) = fstati (IP_FD(ip), F_FILESIZE) * SZB_CHAR + } else if (strncmp(opname, "$FNAME", 3) == 0) { + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + call fstats (IP_FD(ip), F_FILENAME, Memc[buf], SZ_FNAME) + + O_TYPE(o) = TY_CHAR + O_LEN(o) = strlen (Memc[buf]) + 1 + call malloc (O_VALP(o), O_LEN(o), TY_CHAR) + call strcpy (Memc[buf], O_VALC(o), i) + call sfree (sp) + } + + return + } + + nops = IP_NPIXT(ip) + found = NO + do i = 1, nops { + # Search for operand name which matches requested value. + op = PTYPE(ip,i) + if (streq (Memc[IO_TAG(op)],opname)) { + found = YES + break + } + } + + if (VDEBUG) { + call eprintf ("getop: opname=%s tag=%s found=%d ") + call pargstr(opname) ; call pargstr(Memc[IO_TAG(op)]) + call pargi(found) + if (found == YES) call zzi_prop (op) + } + + if (found == YES) { + # Copy operand descriptor to 'o' + optype = ip_ptype (IO_TYPE(op), IO_NBYTES(op)) + switch (optype) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), IO_NPIX(op), TY_SHORT) + call amovs (Mems[IO_DATA(op)], Mems[O_VALP(o)], IO_NPIX(op)) + $for (ilrd) + case TY_PIXEL: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_PIXEL + call malloc (O_VALP(o), IO_NPIX(op), TY_PIXEL) + call amov$t (Mem$t[IO_DATA(op)], Mem$t[O_VALP(o)], IO_NPIX(op)) + $endfor + } + + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call sprintf (Memc[buf], SZ_LINE, "Unknown outbands operand `%s'\n") + call pargstr(opname) + call sfree (sp) + call error (1, Memc[buf]) + } +end + + +# IP_EVALUATE -- Evaluate the outbands expression. + +pointer procedure ip_evaluate (ip, expr) + +pointer ip #i task struct pointer +char expr[ARB] #i expression to be evaluated + +pointer o # operand pointer to result + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_obfcn() +errchk evvexpr + +begin + if (DEBUG) { call eprintf("ip_eval: expr='%s'\n") ; call pargstr(expr) } + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ip_getop), ip, locpr(ip_obfcn), ip, + EV_RNGCHK) + } then + call erract (EA_FATAL) + + return (o) +end + + +# IP_OBFCN -- Called by evvexpr to execute import outbands special functions. + +procedure ip_obfcn (ip, fcn, args, nargs, o) + +pointer ip #i task struct pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf +pointer r, g, b, gray, color, cmap +int i, len, v_nargs, func + +int or(), strdic() +bool strne() + +define setop_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, OB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case GRAY, GREY: + v_nargs = 3 + case FLIPX, FLIPY: + v_nargs = 1 + case RED, GREEN, BLUE: + v_nargs = 1 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + if (DEBUG) { + call eprintf ("obfcn: nargs=%d func=%d\n") + call pargi (nargs) ; call pargi (func) + do i = 1, nargs { call eprintf ("\t") ; call zzi_pevop (args[i]) } + call flush (STDERR) + } + + # Evaluate the function. + switch (func) { + case GRAY, GREY: + # evaluate expression for NTSC grayscale. + r = O_VALP(args[1]) + g = O_VALP(args[2]) + b = O_VALP(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + gray = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mems[r+i] + + G_COEFF * Mems[g+i] + + B_COEFF * Mems[b+i] + } + $for (ilrd) + case TY_PIXEL: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mem$t[r+i] + + G_COEFF * Mem$t[g+i] + + B_COEFF * Mem$t[b+i] + } + $endfor + } + + case RED: + # Get the red colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + r = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Mems[r+i]+1) + $for (il) + case TY_PIXEL: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Mem$t[r+i]+1) + $endfor + } + + case GREEN: + # Get the blue colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + g = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,Mems[g+i]+1) + $for (il) + case TY_PIXEL: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,char(Mem$t[g+i]+1)) + $endfor + } + + case BLUE: + # Get the blue colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + b = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,Mems[b+i]+1) + $for (il) + case TY_PIXEL: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,char(Mem$t[b+i]+1)) + $endfor + } + + case FLIPX: + # Set flag to reverse pixel order on output. + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_X) + goto setop_ + + case FLIPY: + # Set flag to write image from bottom to top. + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_Y) + + # Copy argument operand descriptor to 'o' +setop_ switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), O_LEN(args[1]), TY_SHORT) + call amovs (Mems[O_VALP(ARGS[1])], Mems[O_VALP(o)], O_LEN(o)) + $for (ilrd) + case TY_PIXEL: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_PIXEL + call malloc (O_VALP(o), O_LEN(args[1]), TY_PIXEL) + call amov$t (Mem$t[O_VALP(args[1])], Mem$t[O_VALP(o)], O_LEN(o)) + $endfor + } + + } + + if (DEBUG) { call zzi_pevop (o) } + + call sfree (sp) +end diff --git a/pkg/dataio/import/ipproc.gx b/pkg/dataio/import/ipproc.gx new file mode 100644 index 00000000..38217a4d --- /dev/null +++ b/pkg/dataio/import/ipproc.gx @@ -0,0 +1,804 @@ +include +include +include +include "../import.h" + +define DEBUG false + + +# IP_PRBAND -- Process a band interleaved file. + +procedure ip_prband (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +int i, j, nlines, npix +int optype, nbytes_pix, percent +int cur_offset, band_offset, line_offset + +int ip_ptype() +long ip_lnote() + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + # Compute the offset between the same pixel in different bands. This + # is the area of the image plus any image padding, computed as a + # byte offset. + optype = ip_ptype (IO_TYPE(PTYPE(ip,1)),IO_NBYTES(PTYPE(ip,1))) + switch (optype) { + case TY_UBYTE: nbytes_pix = 1 + case TY_USHORT, TY_SHORT: nbytes_pix = SZB_CHAR * SZ_SHORT + case TY_INT: nbytes_pix = SZB_CHAR * SZ_INT32 + case TY_LONG: nbytes_pix = SZB_CHAR * SZ_LONG + case TY_REAL: nbytes_pix = SZB_CHAR * SZ_REAL + case TY_DOUBLE: nbytes_pix = SZB_CHAR * SZ_DOUBLE + } + band_offset = (IP_AXLEN(ip,1) * (IP_AXLEN(ip,2)-1)) + + ((IP_LSKIP(ip) + IP_LPAD(ip)) * (IP_AXLEN(ip,2)-1)) + + IP_BSKIP(ip) + band_offset = (band_offset * nbytes_pix) #+ 1 + + if (DEBUG) { + call eprintf ("ip_prband: band_offset=%d curpos=%d\n") + call pargi(band_offset) ; call pargi(ip_lnote(fd)) + call zzi_prstruct ("ip_prband", ip) + } + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + npix = IP_AXLEN(ip,1) + percent = 0 + do i = 1, nlines { + # Skip pixels at front of line + line_offset = ip_lnote (fd) + if (IP_LSKIP(ip) != 0) + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line and save as operand. + call ip_rdline (ip, fd, 1, npix, cmap) + + # Skip pixels at end of line. + if (IP_LPAD(ip) != 0) + call ip_lskip (fd, IP_LPAD(ip)) + cur_offset = ip_lnote (fd) + + # Loop over each of the remaining pixtypes. + do j = 2, IP_NPIXT(ip) { + # Seek to offset of next band (i.e. line_offset + band_offset). + call ip_lskip (fd, band_offset) + if (IP_LSKIP(ip) != 0) + call ip_lskip (fd, IP_LSKIP(ip)) + call ip_rdline (ip, fd, j, npix, cmap) # read pixels in the line + if (IP_LPAD(ip) != 0) + call ip_lskip (fd, IP_LPAD(ip)) + } + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + + # Restore file pointer to cur_offset. + call ip_lseek (fd, cur_offset) + } + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PRLINE -- Process a line interleaved file. + +procedure ip_prline (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +int i, j, nlines, npix, percent + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + if (DEBUG) { + call eprintf ("ip_prline:\n") + call zzi_prstruct ("ip_prline", ip) + } + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + npix = IP_AXLEN(ip,1) + percent = 0 + do i = 1, nlines { + + do j = 1, IP_NPIXT(ip) { + # Skip pixels at front of line + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line and save as operand. + call ip_rdline (ip, fd, j, npix, cmap) + + # Skip pixels at end of line. + call ip_lskip (fd, IP_LPAD(ip)) + } + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + } + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PRPIX -- Process a pixel interleaved file. + +procedure ip_prpix (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +pointer op, data +int i, swap, optype, nlines +int percent, npix, totpix + +int and(), ip_ptype() + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + if (DEBUG) { call eprintf ("ip_prpix: ") } + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Allocate the pixtype data pointers. + npix = IP_AXLEN(ip,1) + nlines = IP_NPIXT(ip) + do i = 1, nlines { + op = PTYPE(ip,i) + optype = ip_ptype (IO_TYPE(op),IO_NBYTES(op)) + IO_NPIX(op) = npix + if (IO_DATA(op) == NULL) + if (optype == TY_UBYTE) + call malloc (IO_DATA(op), npix, TY_SHORT) + else + call malloc (IO_DATA(op), npix, optype) + } + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + totpix = npix * IP_NPIXT(ip) + swap = IP_SWAP(ip) + percent = 0 + if (DEBUG) { + call zzi_prstruct ("ip_prpix", ip) + call eprintf ("nl=%d np=%d tp=%d:\n") + call pargi(nlines) ; call pargi(npix) ; call pargi(totpix) + } + do i = 1, nlines { + + # Skip pixels at front of line + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line. + switch (optype) { + case TY_UBYTE: + call ip_agetb (fd, data, totpix) + call ip_lskip (fd, totpix) + # Apply a colormap to the bytes. In general a pixel-interleaved + # file is a 24-bit True Color image, but maybe this is a + # 3-D color index file? + if (cmap != NULL && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], totpix, cmap) + + case TY_USHORT: + call ip_agetu (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (totpix*(SZ_SHORT*SZB_CHAR))) + } + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_SHORT))) + + $for (silrd) + case TY_PIXEL: + call ip_aget$t (fd, data, totpix) + $if (datatype == s) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mem$t[data], 1, Mem$t[data], 1, + (totpix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + $if (datatype == il) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I4) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Mem$t[data], Mem$t[data], totpix) + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (totpix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (totpix*(SZ_INT*SZB_CHAR))) + } + } + $endif + $if (datatype == r) + if (and(swap, S_ALL) == S_ALL) { + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (totpix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + $if (datatype == d) + if (and(swap, S_ALL) == S_ALL) { + call bswap8 (Mem$t[data], 1, Mem$t[data], 1, + (totpix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + + $if (datatype == il) + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_INT32))) + $else + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_PIXEL))) + $endif + $endfor + } + + # Skip pixels at end of line. + call ip_lskip (fd, IP_LPAD(ip)) + + # Separate pixels into different vectors. + call ip_upkpix (ip, data, npix) + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + } + + if (optype == TY_UBYTE) + call mfree (data, TY_SHORT) + else + call mfree (data, optype) + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PROBEXPR -- Process each of the outbands expressions and write the result +# to the output image. + +procedure ip_probexpr (ip, im, npix, line) + +pointer ip #i task struct pointer +pointer im #i output image pointer +int npix #i number of output pixels +int line #i line number + +int i +pointer out, ip_evaluate() + +begin + # Loop over outbands expressions. + do i = 1, IP_NBANDS(ip) { + # Evaluate outbands expression. + out = ip_evaluate (ip, O_EXPR(ip,i)) + + # Write bands to output image + if (IP_OUTPUT(ip) != IP_NONE) + call ip_wrline (ip, im, out, npix, line, i) + + call evvfree (out) + } +end + + +# IP_RDLINE -- Read a line of pixels from the binary file. + +procedure ip_rdline (ip, fd, pnum, npix, cmap) + +pointer ip #i task struct pointer +int fd #i input file descriptor +int pnum #i pixtype number +int npix #i number of pixels to read +pointer cmap #i colormap pointer + +pointer op, data +int swap, ptype + +int and(), ip_ptype() + +begin + # Read pixels in the line and save as operand. + op = PTYPE(ip,pnum) + ptype = ip_ptype (IO_TYPE(op), IO_NBYTES(op)) + data = IO_DATA(op) + swap = IP_SWAP(ip) + IO_NPIX(op) = npix + + switch (ptype) { + case TY_UBYTE: + call ip_agetb (fd, data, npix) + call ip_lskip (fd, npix) + # Apply a colormap to the bytes. If the colormap is non-null we + # assume the bytes are color indices into a colormap. + if (cmap != NULL && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], npix, cmap) + + case TY_USHORT: + call ip_agetu (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (npix*(SZ_SHORT*SZB_CHAR))) + } + call ip_lskip (fd, (npix * (SZB_CHAR * SZ_SHORT))) + $for (silrd) + case TY_PIXEL: + call ip_aget$t (fd, data, npix) + $if (datatype == s) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (npix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + $if (datatype == il) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Mem$t[data], Mem$t[data], npix) + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (npix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (npix*(SZ_PIXEL*SZB_CHAR))) + } + } + $endif + $if (datatype == r) + if (and(swap, S_ALL) == S_ALL) { + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (npix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + $if (datatype == d) + if (and(swap, S_ALL) == S_ALL) { + call bswap8 (Mem$t[data], 1, Mem$t[data], 1, + (npix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + + $if (datatype == il) + call ip_lskip (fd, npix * (SZB_CHAR * SZ_INT32)) + $else + call ip_lskip (fd, npix * (SZB_CHAR * SZ_PIXEL)) + $endif + $endfor + } + IO_DATA(op) = data +end + + +# IP_WRLINE -- Write a line of pixels to the output image. We handle image +# flipping here to avoid possibly doing it several times while the outbands +# expression is being evaluated. + +procedure ip_wrline (ip, im, out, npix, line, band) + +pointer ip #i task struct pointer +pointer im #i output image pointer +pointer out #i output operand pointer +int npix #i number of pixels to read +int line #i image line number +int band #i image band number + +int i, lnum, type +int nldone, blnum +pointer sp, dptr, data, optr +bool lastline + +int and() +pointer imps3s(), imps3i(), imps3l(), imps3r(), imps3d() +pointer ip_chtype() + +data blnum /0/ +data nldone /1/ +data lastline /false/ + +begin + call smark (sp) + + # The first thing we do is change the datatype of the operand to + # match the output pixel type. + if (IP_OUTTYPE(ip) != NULL) { + if (IP_OUTTYPE(ip) == O_TYPE(out)) + optr = O_VALP(out) + else + optr = ip_chtype (out, IP_OUTTYPE(ip)) + } + type = IP_OUTTYPE(ip) + + # See if we're flipping image in Y, and adjust the line number. + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + lnum = IP_AXLEN(ip,2) - line + 1 + if (band == 1) + blnum = IP_SZBUF(ip) - mod (line-1, IP_SZBUF(ip)) + lastline = (lnum == 1) + } else { + lnum = line + if (band == 1) + blnum = blnum + 1 + lastline = (lnum == IP_AXLEN(ip,2)) + } + + # See if we're flipping image in x, and reverse the pixels. + if (and(IP_FLIP(ip),FLIP_X) == FLIP_X) { + call salloc (dptr, npix, type) + do i = 1, npix { + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + Mems[dptr+i-1] = Mems[optr+(npix-i)] + $for (ilrd) + case TY_PIXEL: + Mem$t[dptr+i-1] = Mem$t[optr+(npix-i)] + $endfor + } + } + } else + dptr = optr + + # Make sure the image pixtype is set. + if (IM_PIXTYPE(im) == NULL) + IM_PIXTYPE(im) = type + + # Allocate the buffer pointer if needed. + if (BUFFER(ip,band) == NULL) + call calloc (BUFFER(ip,band), npix*IP_SZBUF(ip), IP_OUTTYPE(ip)) + + if (nldone < IP_SZBUF(ip) && !lastline) { + # Copy the image line to the buffer + data = BUFFER(ip,band) + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovs (Mems[dptr], Mems[data+((blnum-1)*npix)], npix) + $for (ilrd) + case TY_PIXEL: + call amov$t (Mem$t[dptr], Mem$t[data+((blnum-1)*npix)], npix) + $endfor + } + if (band == IP_NBANDS(ip)) + nldone = nldone + 1 + + } else { + # Write the buffer to the image as a section. + data = BUFFER(ip,band) + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovs (Mems[dptr], Mems[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3s (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovs (Mems[BUFFER(ip,band)+(blnum-1)*npix], + Mems[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3s (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovs (Mems[BUFFER(ip,band)], Mems[data], npix*blnum) + } + $for (ilrd) + case TY_PIXEL: + call amov$t (Mem$t[dptr], Mem$t[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3$t (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amov$t (Mem$t[BUFFER(ip,band)+(blnum-1)*npix], + Mem$t[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3$t (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amov$t (Mem$t[BUFFER(ip,band)], Mem$t[data], + npix*blnum) + } + $endfor + } + if (band == IP_NBANDS(ip)) { + nldone = 1 + blnum = 0 + } + } + + if (IP_OUTTYPE(ip) != O_TYPE(out)) + call mfree (optr, type) + call sfree (sp) +end + + +# IP_UPKPIX -- Unpack a line of pixel-interleaved pixels to the separate +# pixtype operand arrays. + +procedure ip_upkpix (ip, ptr, npix) + +pointer ip #i task struct pointer +pointer ptr #i pointer to pixels +int npix #i number of pixels in line + +pointer op[IM_MAXDIM] +int i, j, np, optype[IM_MAXDIM] + +int ip_ptype() + +begin + np = IP_NPIXT(ip) + do j = 1, np { + op[j] = PTYPE(ip,j) + optype[j] = ip_ptype (IO_TYPE(op[j]),IO_NBYTES(op[j])) + } + + do j = 1, np { + + do i = 0, npix-1 { + switch (optype[j]) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + Mems[IO_DATA(op[j])+i] = Mems[ptr+(i*np+j)-1] + $for (ilrd) + case TY_PIXEL: + Mem$t[IO_DATA(op[j])+i] = Mem$t[ptr+(i*np+j)-1] + $endfor + } + } + } +end + + +# IP_FIX_PIXTYPE -- Create the pixtype operands for 3-D band or line- +# interleaved files. These weren't allocated at first since the pixtype +# parameter or database field was atomic. + +procedure ip_fix_pixtype (ip) + +pointer ip #i task struct pointer + +pointer op, op1 +int i, nnp + +begin + if (DEBUG) { + call eprintf ("fix_pixtype: npixt=%d ndim=%d inter=%d\n") + call pargi(IP_NPIXT(ip)) ; call pargi(IP_NDIM(ip)) + call pargi(IP_INTERLEAVE(ip)) ; call flush (STDERR) + } + + # See if there's anything to be fixed. + if (IP_NDIM(ip) < 3 || IP_NDIM(ip) < IP_NPIXT(ip)) + return + if (BAND_INTERLEAVED(ip) && (IP_NPIXT(ip) == IP_NDIM(ip))) + return + if (LINE_INTERLEAVED(ip) && (IP_NPIXT(ip) == IP_INTERLEAVE(ip))) + return + + if (LINE_INTERLEAVED(ip)) + nnp = IP_INTERLEAVE(ip) + else + #nnp = IP_NDIM(ip) + nnp = IP_AXLEN(ip,3) + + # Make the new pixtype operands. + op1 = PTYPE(ip,1) + do i = 2, nnp { + call ip_alloc_operand (PTYPE(ip,i)) + op = PTYPE(ip,i) + IO_TYPE(op) = IO_TYPE(op1) + IO_NBYTES(op) = IO_NBYTES(op1) + call sprintf (OP_TAG(op), SZ_TAG, "b%d") + call pargi (i) + } + IP_NPIXT(ip) = nnp + + if (DEBUG) { call zzi_prstruct ("fix_pixtype", ip) } +end + + +# IP_FIX_OUTBANDS -- Create the outbands operands if none were specified in +# the parameter file. + +procedure ip_fix_outbands (ip) + +pointer ip #i task struct pointer + +pointer sp, buf +pointer im +int i, nbands + +define SZ_OBSTR 2500 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + if (DEBUG) { + call eprintf ("fix_outbands: npixt=%d ndim=%d inter=%d\n") + call pargi(IP_NPIXT(ip)) ; call pargi(IP_NDIM(ip)) + call pargi(IP_INTERLEAVE(ip)) ; call flush (STDERR) + } + + # Free up the existing outbands operands. + nbands = IP_NBANDS(ip) + do i = 1, nbands + call ip_free_outbands (OBANDS(ip,i)) + + # Create an outbands parameter string according to the tags in the + # pixtype structure. This way we preserve any user-defined tags on + # output. + nbands = IP_NPIXT(ip) + call aclrc (Memc[buf], SZ_FNAME) + do i = 1, nbands { + call ip_alloc_outbands (OBANDS(ip,i)) + call aclrc (Memc[buf], SZ_FNAME) + call sprintf (Memc[buf], SZ_FNAME, "b%d") + call pargi (i) + call strcpy (Memc[buf], O_EXPR(ip,i), SZ_EXPR) + + # Load the operand struct. + call strcpy (Memc[buf], OP_TAG(O_OP(ip,i)), SZ_EXPR) + } + IP_NBANDS(ip) = nbands + + # Fix the output image dimensions. + im = IP_IM(ip) + IM_LEN(im,3) = IP_AXLEN(ip,3) + if (IP_NBANDS(ip) > 1) + IM_NDIM(im) = 3 + else + IM_NDIM(im) = IP_NDIM(ip) + + call sfree (sp) + + if (DEBUG) { call zzi_prstruct ("fix_outbands", ip) } +end + + +# IP_CHTYPE - Change the expression operand vector to the output datatype. +# We allocate and return a pointer to the correct type to the converted +# pixels, this pointer must be freed later on. + +pointer procedure ip_chtype (op, type) + +pointer op #i evvexpr operand pointer +int type #i new type of pointer + +pointer out, coerce() + +begin + # Allocate the pointer and coerce it so the routine works. + if (type == TY_UBYTE || type == TY_CHAR) + call calloc (out, O_LEN(op), TY_CHAR) + else { + call calloc (out, O_LEN(op), type) + out = coerce (out, type, TY_CHAR) + } + + # Change the pixel type. + switch (O_TYPE(op)) { + case TY_CHAR: + call achtc (Memc[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_SHORT: + call achts (Mems[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_INT: + call achti (Memi[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_LONG: + call achtl (Meml[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_REAL: + call achtr (Memr[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_DOUBLE: + call achtd (Memd[O_VALP(op)], Memc[out], O_LEN(op), type) + default: + call error (0, "Invalid output type requested.") + } + + out = coerce (out, TY_CHAR, type) + return (out) +end + + +define NTYPES 6 +define NBITPIX 4 + +# IP_PTYPE -- For a given pixtype parameter return the corresponding IRAF +# data type. + +int procedure ip_ptype (type, nbytes) + +int type #i pixel type +int nbytes #i number of bytes + +int i, pt, pb, ptype +int tindex[NTYPES], bindex[NBITPIX], ttbl[NTYPES*NBITPIX] + +data tindex /PT_BYTE, PT_UINT, PT_INT, PT_IEEE, PT_NATIVE, PT_SKIP/ +data bindex /1, 2, 4, 8/ + +data (ttbl(i), i= 1, 4) /TY_UBYTE, TY_USHORT, TY_INT, 0/ # B +data (ttbl(i), i= 5, 8) /TY_UBYTE, TY_USHORT, 0, 0/ # U +data (ttbl(i), i= 9,12) /TY_UBYTE, TY_SHORT, TY_INT, 0/ # I +data (ttbl(i), i=13,16) / 0, 0, TY_REAL, TY_DOUBLE/ # R +data (ttbl(i), i=17,20) / 0, 0, TY_REAL, TY_DOUBLE/ # N +data (ttbl(i), i=21,24) /TY_UBYTE, TY_USHORT, TY_REAL, TY_DOUBLE/ # X + +begin + if (type == 0 || nbytes == 0) # uninitialized values + return (0) + + pt = NTYPES + do i = 1, NTYPES { + if (tindex[i] == type) + pt = i + } + pb = NBITPIX + do i = 1, NBITPIX { + if (bindex[i] == nbytes) + pb = i + } + + ptype = ttbl[(pt-1)*NBITPIX+pb] + if (ptype == 0) + call error (0, "Invalid pixtype specified.") + else + return (ptype) +end + + +# IP_PSTAT - Print information about the progress we're making. + +procedure ip_pstat (ip, row, percent) + +pointer ip #i task struct pointer +int row #u current row +int percent #u percent completed + +begin + # Print percent done if being verbose + if (row * 100 / IP_AXLEN(ip,2) >= percent + 10) { + percent = percent + 10 + call eprintf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDERR) + } +end diff --git a/pkg/dataio/import/mkpkg b/pkg/dataio/import/mkpkg new file mode 100644 index 00000000..c12f77f6 --- /dev/null +++ b/pkg/dataio/import/mkpkg @@ -0,0 +1,37 @@ +# MKPKG file for the IMPORT task + +$call update +$exit + +update: + $checkout libpkg.a ../ + $update libpkg.a + $checkin libpkg.a ../ + ; + +generic: + $set GEN = "$$generic -k" + + $ifolder (generic/ipdb.x, ipdb.gx) + $(GEN) ipdb.gx -o generic/ipdb.x $endif + $ifolder (generic/ipfio.x, ipfio.gx) + $(GEN) ipfio.gx -o generic/ipfio.x $endif + $ifolder (generic/ipobands.x, ipobands.gx) + $(GEN) ipobands.gx -o generic/ipobands.x $endif + $ifolder (generic/ipproc.x, ipproc.gx) + $(GEN) ipproc.gx -o generic/ipproc.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + @generic + @bltins + + fmtdb.x import.h + ipbuiltin.x import.h + ipinfo.x import.h + iplistpix.x + ipmkhdr.x import.h + t_import.x import.h + zzidbg.x import.h + ; diff --git a/pkg/dataio/import/t_import.x b/pkg/dataio/import/t_import.x new file mode 100644 index 00000000..adb37d17 --- /dev/null +++ b/pkg/dataio/import/t_import.x @@ -0,0 +1,768 @@ +include +include +include +include +include "import.h" + +define DEBUG false + + +# T_IMPORT -- Convert a generic binary raster file to an IRAF image. The +# binary file is described either from the task parameters, or as an entry +# in a database of known formats. Access to the database is either by +# specifying the format explicitly, or by scanning the database and evaluating +# an expression which identifies the format. Output is either in the form +# of information about the file to be converted, a list of the file's pixels +# or an IRAF image whose bands are computed from a list of expressions. + +procedure t_import () + +pointer ip # task structure pointer +int binfiles # binary files list pointer +pointer imfiles # output image list pointer +int fdb # format database descriptor +int im # image pointer +pointer sp, bfname, imname # local storage +pointer format, output, fmt, idstr + +int clpopni(), clplen(), imtlen() # function definitions +int clgfil(), open() +int locpr(), imtgetim(), fdb_opendb() +int ip_fcode(), ip_is_builtin() +pointer imtopenp(), ip_init(), fdb_scan_records(), immap() + +extern ip_getop(), ip_dbfcn() +errchk clpopni, clgfil, imtopenp, open, immap + +define done_ 99 + +begin + call smark (sp) # local storage + call salloc (bfname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (format, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (fmt, SZ_FNAME, TY_CHAR) + call salloc (idstr, SZ_FNAME, TY_CHAR) + + ip = ip_init () # allocate task struct pointer + + call ieemapr (YES, YES) # enable IEEE NaN mapping + call ieemapd (YES, YES) + + # Get file names and image lists. + binfiles = clpopni ("binfiles") + imfiles = imtopenp ("images") + + # Get the format parameter. + call clgstr ("format", Memc[format], SZ_FNAME) + call ip_do_fmtpar (ip, Memc[format]) + + # Get task output parameters. + call ip_gout_pars (ip) + + # See if the image lists match. If the lists are empty and we're + # asked for info, just dump the database and leave. + if (IP_OUTPUT(ip) != IP_INFO && IP_OUTPUT(ip) != IP_NONE) { + if (clplen(binfiles) != imtlen(imfiles) && imtlen(imfiles) != 0) { + # Clean up and print an error. + call clpcls (binfiles) + call imtclose (imfiles) + call sfree (sp) + call error (1, "Input and output lists not the same length.") + } + } else if (IP_OUTPUT(ip) == IP_INFO) { + if (clplen(binfiles) == 0 && imtlen(imfiles) == 0) { + fdb = fdb_opendb () + call ip_list_formats (fdb) + call fdb_closedb (fdb) + goto done_ + } + } + + while (clgfil (binfiles, Memc[bfname], SZ_FNAME) != EOF) { + iferr (IP_FD(ip) = open (Memc[bfname], READ_ONLY, BINARY_FILE)) { + call eprintf ("Error opening file '%s'.\n") + call pargstr (Memc[bfname]) + break + } + + # Process the outbands parameter. + call ip_reset_outbands (ip) + + if (IP_FORMAT(ip) == IP_SENSE) { + # Scan the database and get symtab pointer to format record. + fdb = fdb_opendb () + call ip_lseek (fdb, BOF) + IP_FSYM(ip) = fdb_scan_records (fdb, "image_id", + locpr(ip_getop), ip, locpr(ip_dbfcn), ip) + if (IP_FSYM(ip) == NULL) { + # Try it byte-swapped. + IP_SWAP(ip) = S_ALL + call ip_lseek (fdb, BOF) + IP_FSYM(ip) = fdb_scan_records (fdb, "image_id", + locpr(ip_getop), ip, locpr(ip_dbfcn), ip) + IP_SWAP(ip) = NULL + + if (IP_FSYM(ip) == NULL) { + if (IP_OUTPUT(ip) == IP_INFO) { + call printf ("%.19s%20tUnrecognized format\n") + call pargstr (Memc[bfname]) + call fdb_closedb (fdb) + next + } else { + call printf ( + "Unrecognized format. Known formats include:\n\n") + call ip_lseek (fdb, BOF) + call ip_list_formats (fdb) + call fdb_closedb (fdb) + break + } + } + } + call fdb_closedb (fdb) + } + + # See if this is a 'builtin' format. + if (IP_FSYM(ip) != NULL) { + call fdbgstr (IP_FSYM(ip), "format", Memc[fmt], SZ_LINE) + call fdbgstr (IP_FSYM(ip), "id_string", Memc[idstr], SZ_LINE) + call fdb_strip_quote (Memc[idstr], Memc[idstr], SZ_LINE) + IP_BLTIN(ip) = ip_is_builtin (Memc[fmt]) + IP_FCODE(ip) = ip_fcode (Memc[fmt]) + } else + IP_BLTIN(ip) = NO + + + if (IP_FORMAT(ip) != IP_NONE) { + # Evaluate database expressions for this binary file. + call ip_eval_dbrec (ip) + } + + if (IP_OUTPUT(ip) == IP_INFO) { + # Just print some information about the file. + call ip_info (ip, Memc[bfname], IP_VERBOSE(ip)) + + } else { + if (IP_OUTPUT(ip) != IP_NONE) { + # Get an output image name. + if (IP_OUTPUT(ip) == IP_IMAGE) { + if (imtgetim (imfiles, Memc[imname], SZ_FNAME) == EOF) + call error (1, "Short image list.") + } else if (IP_OUTPUT(ip) == IP_LIST) { + # Get a temporary image name. + call mktemp ("tmp$imp", Memc[imname], SZ_FNAME) + } + + # Open the output image. + iferr (im = immap(Memc[imname], NEW_IMAGE, 0)) { + call erract (EA_WARN) + next + } + IP_IM(ip) = im + + # Calculate the size of output image and number of bands. + IM_LEN(im,1) = IP_AXLEN(ip,1) + IM_LEN(im,2) = IP_AXLEN(ip,2) + IM_LEN(im,3) = IP_NBANDS(ip) + if (IP_NBANDS(ip) > 1) + IM_NDIM(im) = 3 + else + IM_NDIM(im) = IP_NDIM(ip) + IM_PIXTYPE(im) = IP_OUTTYPE(ip) + } + + if (IP_VERBOSE(ip) == YES && IP_OUTPUT(ip) != IP_LIST) { + # Print chatter about the conversion. + call printf ("%s -> %s\n ") + call pargstr (Memc[bfname]) + call pargstr (Memc[imname]) + call ip_info (ip, Memc[bfname], NO) + call ip_obinfo (ip, Memc[imname]) + call flush (STDOUT) + } + + if (IP_BLTIN(ip) == YES) { + call ip_prbuiltin (ip, Memc[bfname]) + } else { + # This is it, process the binary file. + if (BAND_INTERLEAVED(ip)) + # Input file is band interleaved. + call ip_prband (ip, IP_FD(ip), IP_IM(ip), NULL) + else if (LINE_INTERLEAVED(ip)) + # Input file is line interleaved. + call ip_prline (ip, IP_FD(ip), IP_IM(ip), NULL) + else if (PIXEL_INTERLEAVED(ip)) + # Input file is pixel interleaved. + call ip_prpix (ip, IP_FD(ip), IP_IM(ip), NULL) + else + call error (0, "Unrecognized pixel storage.") + + if (IP_VERBOSE(ip) == YES) { + call eprintf (" Status: Done \n") + call flush (STDERR) + } + } + + + if (IP_IMHEADER(ip) != NULL && IP_OUTPUT(ip) != IP_NONE) + # Copy header info to new image (can contain wcs info) + call ip_mkheader (IP_IM(ip), Memc[IP_IMHEADER(ip)]) + + if (IP_OUTPUT(ip) == IP_LIST) { + # List the image pixels band by band. + call ip_listpix (IP_IM(ip)) + call imdelete (Memc[imname]) + } + + if (IP_IM(ip) != NULL) + call imunmap (IP_IM(ip)) # close the output image + } + + call close (IP_FD(ip)) + if (IP_FORMAT(ip) == IP_SENSE) + call fdb_close (IP_FSYM(ip)) # free format pointer + } + + # Free task structure ptr and clean up. + call fdb_close (IP_FSYM(ip)) +done_ call ip_free (ip) + call clpcls (binfiles) + call imtclose (imfiles) + call sfree (sp) +end + + +# IP_INIT -- Initialize the task structure pointers. + +pointer procedure ip_init () + +pointer ptr + +begin + # Allocate task structure pointer. + iferr (call calloc (ptr, SZ_IMPSTRUCT, TY_STRUCT)) + call error (0, "Error allocating IMPORT task structure.") + + # Allocate the pixtype, outbands, and buffer struct pointers. + call calloc (IP_PIXTYPE(ptr), MAX_OPERANDS, TY_POINTER) + call calloc (IP_OUTBANDS(ptr), MAX_OPERANDS, TY_POINTER) + call calloc (IP_BUFPTR(ptr), MAX_OPERANDS, TY_POINTER) + + # Initialize some parameters + IP_IM(ptr) = NULL + IP_FD(ptr) = NULL + IP_OFFSET(ptr) = 1 + IP_FLIP(ptr) = FLIP_NONE + + return (ptr) +end + + +# IP_FREE -- Free the task structure pointers. + +procedure ip_free (ip) + +pointer ip #i task struct pointer + +int i + +begin + # Free pixtype pointers. + for (i=1; i < IP_NPIXT(ip); i=i+1) + call mfree (PTYPE(ip,i), TY_STRUCT) + call mfree (IP_PIXTYPE(ip), TY_POINTER) + + # Free outbands pointers. + for (i=1; i < MAX_OPERANDS; i=i+1) + call mfree (OBANDS(ip,i), TY_STRUCT) + call mfree (IP_OUTBANDS(ip), TY_POINTER) + + # Free buffer pointers. + call mfree (IP_BUFPTR(ip), TY_POINTER) + + if (IP_COMPTR(ip) != NULL) + call mfree (IP_COMPTR(ip), TY_CHAR) + call mfree (ip, TY_STRUCT) +end + + +# IP_GIN_PARS -- Get the task input file parameters. + +procedure ip_gin_pars (ip) + +pointer ip #i task struct pointer + +pointer sp, dims, bswap, pixtype + +int clgeti() + +begin + call smark (sp) + call salloc (dims, SZ_FNAME, TY_CHAR) + call salloc (bswap, SZ_FNAME, TY_CHAR) + call salloc (pixtype, SZ_FNAME, TY_CHAR) + + # Get the storage parameters. + IP_HSKIP(ip) = clgeti ("hskip") + IP_TSKIP(ip) = clgeti ("tskip") + IP_BSKIP(ip) = clgeti ("bskip") + IP_LSKIP(ip) = clgeti ("lskip") + IP_LPAD(ip) = clgeti ("lpad") + + # Process the dims parameter. + call aclrc (Memc[dims], SZ_FNAME) + call clgstr ("dims", Memc[dims], SZ_FNAME) + call ip_do_dims (ip, Memc[dims]) + + # Process the bswap parameter. + call aclrc (Memc[bswap], SZ_FNAME) + call clgstr ("bswap", Memc[bswap], SZ_FNAME) + call ip_do_bswap (ip, Memc[bswap]) + + # Process the pixtype parameter. + call aclrc (Memc[pixtype], SZ_FNAME) + call clgstr ("pixtype", Memc[pixtype], SZ_FNAME) + call ip_do_pixtype (ip, Memc[pixtype]) + + if (IP_NPIXT(ip) > 1) + IP_INTERLEAVE(ip) = 0 # composite pixtype, ignore interleave + else + IP_INTERLEAVE(ip) = clgeti ("interleave") + + # Do a little sanity checking. + if (IP_NPIXT(ip) > 1 && IP_NDIM(ip) > IP_NPIXT(ip)) + call error (1, + "Image dimensions don't match `pixtype' specification.") + if (IP_NPIXT(ip) == 1 && IP_NDIM(ip) > 2 && (IP_INTERLEAVE(ip) != 0 && + IP_INTERLEAVE(ip) != IP_AXLEN(ip,3))) + call error (1, + "Dimensions don't match `pixtype' and `interleave' params.") + + if (DEBUG) { call zzi_prstruct ("init inpars", ip) } + call sfree (sp) +end + + +# IP_GOUT_PARS -- Get the task output file parameters. + +procedure ip_gout_pars (ip) + +pointer ip #i task struct pointer + +pointer sp, out, otype, obands, imhead +int btoi(), clgeti() +bool clgetb(), streq() + +begin + call smark (sp) + call salloc (out, SZ_FNAME, TY_CHAR) + call salloc (otype, SZ_FNAME, TY_CHAR) + call salloc (obands, SZ_FNAME, TY_CHAR) + call salloc (imhead, SZ_FNAME, TY_CHAR) + + # Get the type of output to do. + call aclrc (Memc[out], SZ_FNAME) + call clgstr ("output", Memc[out], SZ_FNAME) + switch (Memc[out]) { + case 'i': + if (Memc[out+1] == 'n') # info + IP_OUTPUT(ip) = IP_INFO + else if (Memc[out+1] == 'm') # image + IP_OUTPUT(ip) = IP_IMAGE + case 'l': # list + IP_OUTPUT(ip) = IP_LIST + case 'n': # none, no + IP_OUTPUT(ip) = IP_NONE + default: + call error (2, "Unrecognized output type in 'output'.") + } + + # Get the output image type. + call aclrc (Memc[otype], SZ_FNAME) + call clgstr ("outtype", Memc[otype], SZ_FNAME) + switch (Memc[otype]) { + case 'u': + IP_OUTTYPE(ip) = TY_USHORT + case 's': + IP_OUTTYPE(ip) = TY_SHORT + case 'i': + IP_OUTTYPE(ip) = TY_INT + case 'l': + IP_OUTTYPE(ip) = TY_LONG + case 'r': + IP_OUTTYPE(ip) = TY_REAL + case 'd': + IP_OUTTYPE(ip) = TY_DOUBLE + default: + IP_OUTTYPE(ip) = NULL + call error (2, "Unrecognized output image type in 'outtype'.") + } + + # Process the outbands parameter. + #call ip_reset_outbands (ip) + + # Get optional image header info file name. + call aclrc (Memc[imhead], SZ_FNAME) + call clgstr ("imheader", Memc[imhead], SZ_FNAME) + if (streq (Memc[imhead],"")) { + IP_IMHEADER(ip) = NULL + } else { + call calloc (IP_IMHEADER(ip), SZ_FNAME, TY_CHAR) + call strcpy (Memc[imhead], Memc[IP_IMHEADER(ip)], SZ_FNAME) + } + IP_VERBOSE(ip) = btoi (clgetb("verbose")) + IP_SZBUF(ip) = clgeti ("buffer_size") + + if (DEBUG) { call zzi_prstruct ("init outpars", ip) } + call sfree (sp) +end + + +# IP_RESET_OUTBANDS - Initialize the 'outbands' parameter structure to the +# default values. + +procedure ip_reset_outbands (ip) + +pointer ip #i task struct pointer + +pointer sp, obands +int i + +begin + if (IP_OUTPUT(ip) == IP_INFO) + return + + call smark (sp) + call salloc (obands, SZ_FNAME, TY_CHAR) + + do i = 1, IP_NBANDS(ip) + call ip_free_outbands (OBANDS(ip,i)) + + # Process the outbands parameter. + call aclrc (Memc[obands], SZ_FNAME) + call clgstr ("outbands", Memc[obands], SZ_FNAME) + call ip_do_outbands (ip, Memc[obands]) + + call sfree (sp) +end + + +# IP_DO_BSWAP -- Read the byte-swap string an load the ip structure. + +procedure ip_do_bswap (ip, bswap) + +pointer ip #i task struct pointer +char bswap[ARB] #i byte swap string + +char ch, flag[SZ_FNAME] +int sp, i + +int strdic() + +begin + if (DEBUG) { call eprintf("swap='%s'\n");call pargstr (bswap) } + + sp = 1 + IP_SWAP(ip) = NULL + while (bswap[sp] != EOS) { + i = 1 + for (ch=bswap[sp]; ch != EOS && ch != ','; ch=bswap[sp]) { + flag[i] = ch + i = i + 1 + sp = sp + 1 + } + flag[i] = EOS + if (DEBUG) { call eprintf("\tflag='%s'\n");call pargstr (flag) } + + switch (strdic (flag, flag, SZ_FNAME, SWAP_STR)) { + case 1, 2: + IP_SWAP(ip) = or (IP_SWAP(ip), S_NONE) + case 3: + IP_SWAP(ip) = or (IP_SWAP(ip), S_ALL) + case 4: + IP_SWAP(ip) = or (IP_SWAP(ip), S_I2) + case 5: + IP_SWAP(ip) = or (IP_SWAP(ip), S_I4) + default: + break + } + } +end + + +# IP_DO_DIMS -- Parse the 'dims' parameter to get number of axes and dimensions. + +procedure ip_do_dims (ip, dims) + +pointer ip #i task struct pointer +char dims[ARB] #i dimension string + +char ch +int sp, ndim, npix +int ctoi() + +begin + if (DEBUG) { call eprintf("dims='%s'\n");call pargstr (dims) } + + ndim = 0 + for (sp=1; ctoi(dims[1],sp,npix) > 0; ) { + ndim = ndim + 1 + IP_AXLEN(ip,ndim) = npix + for (ch=dims[sp]; IS_WHITE(ch) || ch == ','; ch=dims[sp]) + sp = sp + 1 + } + if (ndim == 1) + IP_AXLEN(ip,2) = 1 + IP_NDIM(ip) = ndim +end + + +# IP_DO_FMTPAR -- Given the format parameter, figure out what to do with it. + +procedure ip_do_fmtpar (ip, format) + +pointer ip #i task struct pointer +char format[ARB] #i format string + +pointer fsym +int fd + +int fdb_opendb() +pointer fdb_get_rec() +bool streq() + +begin + if (DEBUG) { call eprintf("format='%s'\n");call pargstr(format) } + + IP_FSYM(ip) = NULL + if (streq(format,"none")) { + # Get the task input parameters. + IP_FORMAT(ip) = IP_NONE + call ip_gin_pars (ip) + + } else if (streq(format,"sense")) { + # Set a flag and figure it out from the database later. + IP_FORMAT(ip) = IP_SENSE + + } else { + # Get a pointer to a symtab entry for the requested format + IP_FORMAT(ip) = IP_NAME + fd = fdb_opendb () + fsym = fdb_get_rec (fd, format) + call fdb_closedb (fd) + if (fsym == NULL) { + call error (2,"Requested format not found in the database.") + } else + IP_FSYM(ip) = fsym + } +end + + +# IP_DO_PIXTYPE -- Process the pixtype parameter + +procedure ip_do_pixtype (ip, pixtype) + +pointer ip #i task struct pointer +char pixtype[ARB] #i pixtype string + +int i, pp, npix, nbytes +pointer op + +int ctoi() + +begin + if (DEBUG) { call eprintf("pixtype=:%s:\n");call pargstr(pixtype) } + + # Check for a bonehead user. + if (pixtype[2] == EOS || pixtype[2] == ',') { + call error (0, "Invalid `pixtype' parameter: no size given") + } + + pp = 1 + npix = 0 + nbytes = ERR + repeat { + npix = npix + 1 + + call ip_alloc_operand (PTYPE(ip,npix)) + op = PTYPE(ip,npix) + + # Get pixel type. + switch (pixtype[pp]) { + case 'b': + IO_TYPE(op) = PT_BYTE + case 'u': + IO_TYPE(op) = PT_UINT + case 'i': + IO_TYPE(op) = PT_INT + case 'r': + IO_TYPE(op) = PT_IEEE + case 'n': + IO_TYPE(op) = PT_NATIVE + case 'x': + IO_TYPE(op) = PT_SKIP + } + pp = pp + 1 + + # Get the number of bytes. + i = ctoi (pixtype, pp, IO_NBYTES(op)) + + # Force equivalence of 'b1' and 'u1' pixtypes. + if (IO_TYPE(op) == PT_UINT && IO_NBYTES(op) == 1) + IO_TYPE(op) = PT_BYTE + + # Get a tag name or create one. + if (pixtype[pp] == ',' || pixtype[pp] == EOS) { # no tag given + call sprintf (OP_TAG(op), SZ_TAG, "b%d") + call pargi (npix) + if (pixtype[pp] != EOS) + pp = pp + 1 + } else if (pixtype[pp] == ':') { # get the tag + pp = pp + 1 + for (i=1; (pixtype[pp] != ',' && pixtype[pp] != EOS) ; i=i+1) { + Memc[IO_TAG(op)+i-1] = pixtype[pp] + pp = pp + 1 + } + pp = pp + 1 + } + + # Make sure all of the pixtypes are the same datatype. + if (nbytes != ERR) { + if (nbytes != IO_NBYTES(op)) + call error (0, "Pixtypes must all be the same size") + } else + nbytes = IO_NBYTES(op) + + if (DEBUG) { call zzi_prop (op) } + + } until (pixtype[pp] == EOS) + IP_NPIXT(ip) = npix +end + + +# IP_DO_OUTBANDS -- Get the outbands parameter and break it up into a list +# of individual expressions. + +procedure ip_do_outbands (ip, outbands) + +pointer ip #i task struct pointer +char outbands[ARB] #i outbands string + +pointer sp, buf +int i, op, nbands, level + +int strsearch() + +begin + # If there is no outbands parameter specified, warn the user, we'll + # make something up later. + IP_USE_CMAP(ip) = YES + if (outbands[1] == EOS && IP_OUTPUT(ip) != IP_INFO) { + call eprintf ("Warning: No 'outbands' parameter specified: ") + call eprintf ("Converting all pixels.\n") + IP_NBANDS(ip) = ERR + return + } + + call smark (sp) + call salloc (buf, SZ_EXPR, TY_CHAR) + call aclrc (Memc[buf], SZ_EXPR) + + if (DEBUG) { call eprintf("outbands='%s'\n");call pargstr(outbands) } + + op = 1 + nbands = 0 + while (outbands[op] != EOS) { + level = 0 + nbands = nbands + 1 + # Copy expr up to the delimiting comma into a buffer. + call aclrc (Memc[buf], SZ_EXPR) + for (i=0; i < SZ_EXPR; i = i + 1) { + if (outbands[op] == '(') { + level = level + 1 + Memc[buf+i] = outbands[op] + } else if (outbands[op] == ')') { + level = level - 1 + Memc[buf+i] = outbands[op] + } else if ((outbands[op] == ',' && level == 0) || + outbands[op] == EOS) { + Memc[buf+i] = EOS + op = op + 1 + break + } else if (! IS_WHITE(outbands[op])) + Memc[buf+i] = outbands[op] + op = op + 1 + } + + if (Memc[buf] != EOS) { + # Save expression to main outbands structure. + call ip_alloc_outbands (OBANDS(ip,nbands)) + call strcpy (Memc[buf], O_EXPR(ip,nbands), SZ_EXPR) + + if (strsearch(Memc[buf], "red") > 0 || + strsearch(Memc[buf], "green") > 0 || + strsearch(Memc[buf], "blue") > 0) + IP_USE_CMAP(ip) = NO + + # Load the operand struct. + call strcpy (Memc[buf], OP_TAG(O_OP(ip,nbands)), SZ_EXPR) + + if (DEBUG) { call zzi_proband (ip, nbands) } + } + } + IP_NBANDS(ip) = nbands + IP_AXLEN(ip,3) = nbands + + call sfree (sp) +end + + +# IP_ALLOC_OUTBANDS -- Allocate an outbands structure. + +procedure ip_alloc_outbands (op) + +pointer op #i outbands struct pointer + +begin + call calloc (op, LEN_OUTBANDS, TY_STRUCT) + call calloc (OB_EXPR(op), SZ_EXPR, TY_CHAR) + call ip_alloc_operand (OB_OP(op)) +end + + +# IP_FREE_OUTBANDS -- Free an outbands structure. + +procedure ip_free_outbands (op) + +pointer op #i outbands struct pointer + +begin + call ip_free_operand (OB_OP(op)) + call mfree (OB_EXPR(op), TY_CHAR) + call mfree (op, TY_STRUCT) +end + + +# IP_ALLOC_OPERAND -- Allocate an operand structure. + +procedure ip_alloc_operand (op) + +pointer op #i operand struct pointer + +begin + call calloc (op, LEN_OPERAND, TY_STRUCT) + call calloc (IO_TAG(op), SZ_FNAME, TY_CHAR) +end + + +# IP_FREE_OPERAND -- Free an operand structure. + +procedure ip_free_operand (op) + +pointer op #i operand struct pointer + +begin + call mfree (IO_TAG(op), TY_CHAR) + call mfree (op, TY_STRUCT) +end diff --git a/pkg/dataio/import/zzidbg.x b/pkg/dataio/import/zzidbg.x new file mode 100644 index 00000000..25c58778 --- /dev/null +++ b/pkg/dataio/import/zzidbg.x @@ -0,0 +1,145 @@ +include +include "import.h" + +procedure zzi_prstruct (whence, ip) + +char whence[SZ_FNAME] +pointer ip +int i + +begin + call eprintf ("%s:\n") ; call pargstr (whence) + call eprintf ("\tformat=%s interleave=%d bswap=%s\n") + switch (IP_FORMAT(ip)) { + case IP_NONE: call pargstr ("IP_NONE") + case IP_SENSE: call pargstr ("IP_SENSE") + case IP_NAME: call pargstr ("IP_NAME") + case IP_BUILTIN: call pargstr ("IP_BUILTIN") + default: call pargstr ("ERR") + } + call pargi (IP_INTERLEAVE(ip)) + switch(IP_SWAP(ip)) { + case S_NONE: call pargstr ("S_NONE") + case S_ALL: call pargstr ("S_ALL") + case S_I2: call pargstr ("S_I2") + case S_I4: call pargstr ("S_I4") + default: call pargstr ("ERR") + } + call eprintf ("\thskip=%d tskip=%d bskip=%d lskip=%d lpad=%d\n") + call pargi (IP_HSKIP(ip)) + call pargi (IP_TSKIP(ip)) + call pargi (IP_BSKIP(ip)) + call pargi (IP_LSKIP(ip)) + call pargi (IP_LPAD(ip)) + call eprintf ("\tndim=%s dims=(%d,%d,%d,%d,%d,%d,%d)\n") + call pargi (IP_NDIM(ip)) + do i = 1, 7 + call pargi (IP_AXLEN(ip,i)) + + call eprintf ("\toutput=%s outtype=%s imheader='%s' verbose=%d\n") + switch(IP_OUTPUT(ip)) { + case IP_NONE: call pargstr ("IP_NONE") + case IP_IMAGE: call pargstr ("IP_IMAGE") + case IP_LIST: call pargstr ("IP_LIST") + case IP_INFO: call pargstr ("IP_INFO") + default: call pargstr ("ERR") + } + switch(IP_OUTTYPE(ip)) { + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + default: call pargstr ("ERR") + } + if (IP_IMHEADER(ip) == NULL) + call pargstr ("") + else + call pargstr (Memc[IP_IMHEADER(ip)]) + call pargi (IP_VERBOSE(ip)) + call eprintf ("\tpixtype:\n") + do i = 1, IP_NPIXT(ip) { + call eprintf ("\t ") + call zzi_prop (PTYPE(ip,i)) + } + call eprintf ("\toutbands:\n") + do i = 1, IP_NBANDS(IP) { + call eprintf ("\t ") + call zzi_proband (ip, i) + } + call flush (STDERR) +end + + +procedure zzi_proband (ip,band) + +pointer ip +int band + +begin + call eprintf ("ob=%d expr='%s' op->") + call pargi (OBANDS(ip,band)) + call pargstr (O_EXPR(ip,band)) + call zzi_prop (O_OP(ip,band)) +end + + +procedure zzi_prop (o) + +pointer o +char buf[8] +int type, ip_ptype() + +begin + call sprintf (buf, 8, " buirnx") + type = ip_ptype(IO_TYPE(o), IO_NBYTES(o)) + call eprintf ("(o=%d expr='%s' tag='%s' (t='%c' N=%d=>%s) Np=%d %d)\n") + call pargi (o) + call pargstr (Memc[OB_EXPR(o)]) + call pargstr (OP_TAG(o)) + call pargc (buf[IO_TYPE(o)+1]) + call pargi (IO_NBYTES(o)) + switch (type) { + case TY_UBYTE: call pargstr ("TY_UBYTE") + case TY_USHORT: call pargstr ("TY_USHORT") + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + default: call pargstr ("ERR") + } + call pargi (IO_NPIX(o)) + call pargi (IO_DATA(o)) + call flush (STDERR) +end + + +procedure zzi_pevop (o) + +pointer o + +begin + call eprintf ("o=%d type=%d len=%d flags=%d ") + call pargi (o) + call pargi (O_TYPE(o)) + call pargi (O_LEN(o)) + call pargi (O_FLAGS(o)) + switch (O_TYPE(o)) { + case TY_CHAR: + call eprintf ("val='%s'\n") ; call pargstr (O_VALC(o)) + case TY_SHORT: + call eprintf ("val=%d\n") ; call pargs (O_VALS(o)) + case TY_INT: + call eprintf ("val=%d\n") ; call pargi (O_VALI(o)) + case TY_LONG: + call eprintf ("val=%d\n") ; call pargl (O_VALL(o)) + case TY_REAL: + call eprintf ("val=%g\n") ; call pargr (O_VALR(o)) + case TY_DOUBLE: + call eprintf ("val=%g\n") ; call pargd (O_VALD(o)) + default: + call eprintf ("ptr=%d\n") ; call pargi (O_VALP(o)) + } + call flush (STDERR) +end diff --git a/pkg/dataio/imtext/imtext.h b/pkg/dataio/imtext/imtext.h new file mode 100644 index 00000000..76506eda --- /dev/null +++ b/pkg/dataio/imtext/imtext.h @@ -0,0 +1,21 @@ +# Definitions used for conversions between text files and IRAF images. +# Both tasks rtextimage and wtextimage include this file. + +define LEN_WT (2+20+20) + +define IRAFTYPE Memc[P2C($1)] +define FORM Memc[P2C($1+20)] + +define UNSET 0 # Flag for unitialized header values +define INT_FORM 1 # Text file pixels written as integers +define FP_FORM 2 # Text file pixels written as floating point +define CPX_FORM 3 # Text file pixels written as complex + +define COL_VALUE 11 # Starting column for FITS keyword values +define LEN_CARD 80 +define SZ_STRING 20 +define MAX_LENTEXT (2*SZ_LINE) +define NFITS_LINES 10 +define NCARDS_FITS_BLK 36 +define LEN_STRING 18 +define LEN_KEYWORD 8 diff --git a/pkg/dataio/imtext/mkpkg b/pkg/dataio/imtext/mkpkg new file mode 100644 index 00000000..8cabe34c --- /dev/null +++ b/pkg/dataio/imtext/mkpkg @@ -0,0 +1,19 @@ +# The image to text file conversion program WTEXTIMAGE makes the following +# contributions to the dataio package library: + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + putcplx.x + putint.x + putreal.x + wti_wheader.x imtext.h + t_wtextimage.x imtext.h + rt_rheader.x imtext.h + rt_cvtpix.x imtext.h + rt_rwpix.x imtext.h + t_rtextimage.x imtext.h + ; diff --git a/pkg/dataio/imtext/putcplx.x b/pkg/dataio/imtext/putcplx.x new file mode 100644 index 00000000..df498479 --- /dev/null +++ b/pkg/dataio/imtext/putcplx.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# WTI_PUTCOMPLEX -- Output pixels to a text file in complex floating format. +# Pixels are output in storage order for images of any dimension (leftmost +# subscript varying fastest). We do not bother to implement a different +# datapath for each image pixel datatype because the execution time is +# entirely dominated by the binary to character conversion, and because we +# need type complex pixels for XTOC anyhow. + +procedure wti_putcomplex (im, tx, maxll, decpl, fmtchar, width) + +pointer im # pointer to image file +int tx # file descriptor of output text file +int maxll # maximum length of output text line +int decpl # number of decimal places of precision +int fmtchar # format character (efg) +int width # field width of each number (0=free format) + +char numbuf[MAX_DIGITS] +int npix, ip, j, ndigits, nspaces, maxch +pointer sp, obuf, op, pix, cp +long v[IM_MAXDIM] +int imgnlx(), xtoc() +errchk imgnlx, putline + +begin + call smark (sp) + call salloc (obuf, maxll+1, TY_CHAR) + + call amovkl (long(1), v, IM_MAXDIM) + npix = IM_LEN(im,1) + op = obuf + + while (imgnlx (im, pix, v) != EOF) { + do j = 1, npix { + # Encode the number. + if (width <= 0) + maxch = MAX_DIGITS + else + maxch = width + + ndigits = xtoc (Memx[pix+j-1], numbuf, MAX_DIGITS, + decpl, fmtchar, maxch) + + # Determine the number of spaces needed to right justify the + # field. If the field width is zero the output is free format + # and we always output a single space. + + if (width <= 0) + nspaces = 1 + else + nspaces = width - ndigits + + # Break the output line if insufficient space remains on the + # line. + + if (op-obuf + ndigits + nspaces > maxll) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + op = obuf + } + + # Append sufficient blanks to right justify the number in + # the given field. + do cp = op, op + nspaces - 1 + Memc[cp] = ' ' + op = op + nspaces + + # Append the number to the output line. + do ip = 1, ndigits + Memc[op+ip-1] = numbuf[ip] + op = op + ndigits + } + } + + # Break the last line if there is anything on it. + if (op > obuf) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + } + + call sfree (sp) +end diff --git a/pkg/dataio/imtext/putint.x b/pkg/dataio/imtext/putint.x new file mode 100644 index 00000000..a98d3fb5 --- /dev/null +++ b/pkg/dataio/imtext/putint.x @@ -0,0 +1,160 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# WTI_PUTINT -- Output pixels to a text file in integer format. Pixels are +# output in storage order for images of any dimension (leftmost subscript +# varying fastest). + +procedure wti_putint (im, tx, maxll, width) + +pointer im # pointer to image file +int tx # file descriptor of output text file +int maxll # maximum length of output text line +int width # field width of each number (0=free format) + +char numbuf[MAX_DIGITS] +int npix, ip, j, ndigits +pointer sp, obuf, op, pix +long v[IM_MAXDIM] +int imgnll(), ltoc() +errchk imgnll, putline + +begin + call smark (sp) + call salloc (obuf, maxll+1, TY_CHAR) + + call amovkl (long(1), v, IM_MAXDIM) + npix = IM_LEN(im,1) + op = obuf + + if (width <= 0) { + # If the encoding is free format call LTOC to encode the number, + # compute the number of spaces required to right justify the + # numeric string in the specified field width, then move the + # spaces and the number into the output line. + + while (imgnll (im, pix, v) != EOF) { + do j = 1, npix { + # Encode the number. + ndigits = ltoc (Meml[pix+j-1], numbuf, MAX_DIGITS) + + # Break output line if insufficient space remains. + if (op-obuf + ndigits + 1 > maxll) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + op = obuf + } + + # Append a blank and the number to the output line. + if (op > obuf) { + Memc[op] = ' ' + op = op + 1 + } + do ip = 1, ndigits + Memc[op+ip-1] = numbuf[ip] + op = op + ndigits + } + } + + } else { + # Fixed format. Encode the integer number from right to left + # in the given field, blank filling at the left. Note that + # fancy formats such as left justify or zero fill are not + # presently supported (and are probably not worth it here). + + while (imgnll (im, pix, v) != EOF) { + do j = 1, npix { + # Break output line if insufficient space remains. + if (op-obuf + width > maxll) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + op = obuf + } + + # Encode the number in the output field. + call wti_encode_l (Meml[pix+j-1], Memc[op], width) + op = op + width + } + } + } + + # Break the last line if there is anything on it. + if (op > obuf) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + } + + call sfree (sp) +end + + +# WTI_ENCODE_L -- Encode a long integer number as a decimal integer, right +# justified with blank fill in the indicated field. Since we know the field +# width in advance we can encode the number from right to left (least +# significant digits first), without having to reverse the digits and copy +# the string as is the case with LTOC. +procedure wti_encode_l (lval, out, w) + +long lval # number to be encoded +char out[w] # output field (NOT EOS DELIMITED) +int w # field width + +bool neg +int op, i +long val, quotient +define overflow_ 91 + +begin + if (IS_INDEFL (lval)) { + if (w < 5) + goto overflow_ + call amovc ("INDEF", out[w-4], 5) + op = w - 5 + + } else { + neg = (lval < 0) + if (neg) + val = -lval + else + val = lval + + # Output digits from right to left. + do i = w, 1, -1 { + quotient = val / 10 + out[i] = TO_DIGIT (val - quotient * 10) + val = quotient + if (val == 0) { + op = i - 1 + break + } + } + + # Add minus sign if negative. + if (neg) { + if (op > 0) + out[op] = '-' + op = op - 1 + } + + # Check for overflow. + if (op < 0 || val > 0) + goto overflow_ + } + + # Blank fill at left. + do i = op, 1, -1 + out[i] = ' ' + + return + +overflow_ + # Number was too large to fit in the given field width. + do i = 1, w + out[i] = '*' +end diff --git a/pkg/dataio/imtext/putreal.x b/pkg/dataio/imtext/putreal.x new file mode 100644 index 00000000..217a45aa --- /dev/null +++ b/pkg/dataio/imtext/putreal.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# WTI_PUTREAL -- Output pixels to a text file in a floating point format. +# Pixels are output in storage order for images of any dimension (leftmost +# subscript varying fastest). We do not bother to implement a different +# datapath for each image pixel datatype because the execution time is +# entirely dominated by the binary to character conversion, and because we +# need type double pixels for DTOC anyhow. + +procedure wti_putreal (im, tx, maxll, decpl, fmtchar, width) + +pointer im # pointer to image file +int tx # file descriptor of output text file +int maxll # maximum length of output text line +int decpl # number of decimal places of precision +int fmtchar # type of encoding (efg) +int width # field width of each number (0=free format) + +char numbuf[MAX_DIGITS] +int npix, ip, j, ndigits, nspaces, maxch +pointer sp, obuf, op, pix, cp +long v[IM_MAXDIM] +int imgnld(), dtoc() +errchk imgnld, putline + +begin + call smark (sp) + call salloc (obuf, maxll+1, TY_CHAR) + + call amovkl (long(1), v, IM_MAXDIM) + npix = IM_LEN(im,1) + op = obuf + + while (imgnld (im, pix, v) != EOF) { + do j = 1, npix { + # Encode the number. + if (width <= 0) + maxch = MAX_DIGITS + else + maxch = width + + ndigits = dtoc (Memd[pix+j-1], numbuf, MAX_DIGITS, + decpl, fmtchar, maxch) + + # Determine the number of spaces needed to right justify the + # field. If the field width is zero the output is free format + # and we always output a single space. + + if (width <= 0) + nspaces = 1 + else + nspaces = width - ndigits + + # Break the output line if insufficient space remains on the + # line. + + if (op-obuf + ndigits + nspaces > maxll) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + op = obuf + } + + # Append sufficient blanks to right justify the number in + # the given field. + do cp = op, op + nspaces - 1 + Memc[cp] = ' ' + op = op + nspaces + + # Append the number to the output line. + do ip = 1, ndigits + Memc[op+ip-1] = numbuf[ip] + op = op + ndigits + } + } + + # Break the last line if there is anything on it. + if (op > obuf) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + } + + call sfree (sp) +end diff --git a/pkg/dataio/imtext/rt_cvtpix.x b/pkg/dataio/imtext/rt_cvtpix.x new file mode 100644 index 00000000..170a26d4 --- /dev/null +++ b/pkg/dataio/imtext/rt_cvtpix.x @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imtext.h" + +# RT_CONVERT_PIXELS -- Called once for each text file to be converted. All +# pixels in the text file are converted to image pixels. + +procedure rt_convert_pixels (tf, im, format, pixels) + +int tf # File descriptor of input text file +pointer im # Pointer to image header +int format # Format of text pixels (integer/floating point) +int pixels # Get pixels from input text file? + +pointer bufptr, sp, word1, pattern +int stat, nlines, npix, i +long v[IM_MAXDIM], start +int impnll(), impnld(), impnlx() +int fscan(), stridxs(), patmatch(), patmake() +long note() + +errchk impnll, impnld, impnlx +errchk rt_get_lineptr, rt_output_line, fscan, seek, amovkl + +begin + # Determine if text file pixels were written with an integer, complex + # or floating point format. This information may have been already + # determined from the header. If not, the first pixel is read + # from text file. If it contains a decimal point, the character E, + # or a + or - sign not in the first position, it is a floating point + # number. Complex numbers are assumed to be written as "(r,i)". + + if (pixels == YES && format == UNSET) { + call smark (sp) + call salloc (word1, SZ_LINE, TY_CHAR) + call salloc (pattern, SZ_LINE, TY_CHAR) + + # Note position so we can return to it + start = note (tf) + + stat = fscan (tf) + call gargwrd (Memc[word1], SZ_LINE) + if (patmake ("[DdEe]", Memc[pattern], SZ_LINE) == ERR) + call error (7, "Error creating format pattern") + + if (stridxs ("(", Memc[word1]) > 0) + format = CPX_FORM + else if (stridxs (".", Memc[word1]) > 0) + format = FP_FORM + else if (patmatch (Memc[word1], Memc[pattern]) > 0) + format = FP_FORM + else if (stridxs ("+", Memc[word1]) > 1) + format = FP_FORM + else if (stridxs ("-", Memc[word1]) > 1) + format = FP_FORM + else + format = INT_FORM + + call sfree (sp) + call seek (tf, start) + } + + # Pixel type may not have been set by this point either... + if (IM_PIXTYPE(im) == UNSET) { + switch (format) { + case FP_FORM: + IM_PIXTYPE(im) = TY_REAL + case INT_FORM: + IM_PIXTYPE(im) = TY_INT + case CPX_FORM: + IM_PIXTYPE(im) = TY_COMPLEX + default: + call error (0, "Unrecognized format type") + } + } + + nlines = 1 + do i = 2, IM_NDIM(im) + nlines = nlines * IM_LEN (im, i) + call amovkl (long(1), v, IM_MAXDIM) + npix = IM_LEN (im, 1) + + # Initialize text buffer + call rt_rinit + + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + do i = 1, nlines { + stat = impnll (im, bufptr, v) + if (pixels == YES) + call rt_output_linel (tf, format, bufptr, npix) + else + call aclrl (Meml[bufptr], npix) + } + case TY_REAL, TY_DOUBLE: + do i = 1, nlines { + stat = impnld (im, bufptr, v) + if (pixels == YES) + call rt_output_lined (tf, format, bufptr, npix) + else + call aclrd (Memd[bufptr], npix) + } + case TY_COMPLEX: + do i = 1, nlines { + stat = impnlx (im, bufptr, v) + if (pixels == YES) + call rt_output_linex (tf, format, bufptr, npix) + else + call aclrx (Memx[bufptr], npix) + } + default: + call error (0, "Image pixel type unset") + } +end diff --git a/pkg/dataio/imtext/rt_rheader.x b/pkg/dataio/imtext/rt_rheader.x new file mode 100644 index 00000000..9c4323bf --- /dev/null +++ b/pkg/dataio/imtext/rt_rheader.x @@ -0,0 +1,170 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imtext.h" + +# RT_RHEADER -- read FITS header, saving the image dimension information in +# the image header. The format (integer/floating point) is returned. + +procedure rt_rheader (tf, im, format) + +int tf # File descriptor for input text file +pointer im # Pointer to image header +int format # Format of text file pixels (integer/floating point) + +pointer sp, wt, card +bool streq() +int ncard, fd_user, max_lenuser +int getline(), rt_decode_card(), stridxs(), strlen(), stropen() +errchk getline, rt_decode_card + +begin + call smark (sp) + call salloc (wt, LEN_WT, TY_STRUCT) + call salloc (card, LEN_CARD+1, TY_CHAR) + + Memc[card+LEN_CARD] = '\n' + Memc[card+LEN_CARD+1] = EOS + + # Prepare user area string to be written + max_lenuser = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + fd_user = stropen (Memc[IM_USERAREA(im)], max_lenuser, NEW_FILE) + + ncard = 1 + repeat { + if (getline (tf, Memc[card]) == EOF) + call error (2, "RT_RHEADER: EOF encountered before END card") + + ncard = ncard + 1 + if (rt_decode_card (wt, im, fd_user, Memc[card]) == YES) + break + } + + # Encountered END card; examine a few header keyword values. From + # the FORMAT keyword, determine if the pixel values are written as + # integers, floating point numbers or complex numbers. + + if (strlen (FORM(wt)) > 0) { + if (stridxs ("I", FORM(wt)) > 0) + format = INT_FORM + else if (stridxs ("(", FORM(wt)) > 0) + format = CPX_FORM + else + format = FP_FORM + } else + format = UNSET + + # The image pixel type is set by the IRAFTYPE keyword value. + + if (streq (IRAFTYPE(wt), "SHORT INTEGER")) + IM_PIXTYPE (im) = TY_SHORT + else if (streq (IRAFTYPE(wt), "UNSIGNED SHORT INT")) + IM_PIXTYPE (im) = TY_USHORT + else if (streq (IRAFTYPE(wt), "INTEGER")) + IM_PIXTYPE (im) = TY_INT + else if (streq (IRAFTYPE(wt), "LONG INTEGER")) + IM_PIXTYPE (im) = TY_LONG + else if (streq (IRAFTYPE(wt), "REAL FLOATING")) + IM_PIXTYPE (im) = TY_REAL + else if (streq (IRAFTYPE(wt), "DOUBLE FLOATING")) + IM_PIXTYPE (im) = TY_DOUBLE + else if (streq (IRAFTYPE(wt), "COMPLEX")) + IM_PIXTYPE (im) = TY_COMPLEX + + call close (fd_user) + call sfree (sp) +end + + +# RT_DECODE_CARD -- Decode a FITS format card and return YES when the END +# card is encountered. The decoded value is stored in the image header, +# or in the user area if there is no other place for it. The END card is +# tested only to the first three characters; strictly speaking the END +# card begins with the 8 characters "END ". + +int procedure rt_decode_card (wt, im, fd, card) + +pointer wt # Pointer to wtextimage keyword structure +pointer im # Pointer to image header being written +int fd # File descriptor of user area +char card[ARB] # Card image read from FITS header + +int nchar, ival, i, j, k, ndim + +int strmatch(), ctoi() +errchk rt_get_fits_string, putline, putline + +begin + + i = COL_VALUE + if (strmatch (card, "^END") > 0) + return (YES) + + else if (strmatch (card, "^NAXIS ") > 0) { + nchar = ctoi (card, i, ndim) + if (ndim > 0) + IM_NDIM(im) = ndim + + } else if (strmatch (card, "^NAXIS") > 0) { + k = strmatch (card, "^NAXIS") + nchar = ctoi (card, k, j) + nchar = ctoi (card, i, IM_LEN(im,j)) + + } else if (strmatch (card, "^NDIM ") > 0) + nchar = ctoi (card, i, IM_NDIM(im)) + + else if (strmatch (card, "^LEN") > 0) { + k = strmatch (card, "^LEN") + nchar = ctoi (card, k, j) + nchar = ctoi (card, i, IM_LEN(im,j)) + + } else if (strmatch (card, "^BITPIX ") > 0) { + nchar = ctoi (card, i, ival) + if (ival != 8) + call error (6, "Not 8-bit ASCII characters") + + } else if (strmatch (card, "^FORMAT ") > 0) { + call rt_get_fits_string (card, FORM(wt), SZ_STRING) + } else if (strmatch (card, "^IRAFTYPE") > 0) { + call rt_get_fits_string (card, IRAFTYPE(wt), SZ_STRING) + } else if (strmatch (card, "^OBJECT ") > 0) { + call rt_get_fits_string (card, IM_TITLE(im), SZ_IMTITLE) + } else { + # Putline returns an error if there is no room in the user area + iferr (call putline (fd, card)) { + call eprintf ("Space in user area has been exceeded\n") + return (YES) + } + } + + return (NO) +end + + +# RT_GET_FITS_STRING -- Extract a string from a FITS card and trim trailing +# blanks. The EOS is marked by either ', /, or the end of the card. +# There may be an optional opening ' (FITS standard). + +procedure rt_get_fits_string (card, str, maxchar) + +char card[ARB] # Input card image containing keyword and value +char str[maxchar] # Output string +int maxchar # Maximum number of characters output +int j, istart, nchar + +begin + # Check for opening quote + if (card[COL_VALUE] == '\'') + istart = COL_VALUE + 1 + else + istart = COL_VALUE + + for (j=istart; (j < LEN_CARD) && (card[j] != '\''); j=j+1) + ; + for (j=j-1; (j >= istart) && (card[j] == ' '); j=j-1) + ; + + nchar = min (maxchar, j - istart + 1) + call strcpy (card[istart], str, nchar) +end diff --git a/pkg/dataio/imtext/rt_rwpix.x b/pkg/dataio/imtext/rt_rwpix.x new file mode 100644 index 00000000..a3ba26bf --- /dev/null +++ b/pkg/dataio/imtext/rt_rwpix.x @@ -0,0 +1,271 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imtext.h" + +# RT_RINIT -- Initialize buffer and buffer pointer for reading text. + +procedure rt_rinit () + +int ip +char text_buf[SZ_LINE] +common /rpix_init/ ip, text_buf + +begin + ip = 1 + text_buf[1] = EOS +end + + +# RT_OUTPUT_LINEL -- Put line of long pixels to image from text file. + +procedure rt_output_linel (tf, format, bufptr, npix) + +int tf # File descriptor for input text file +int format # Format of pixels in text file (integer/ floating) +pointer bufptr # Pointer to image line to be filled +int npix # Number of pixels per image line + +pointer sp, dbl_buf, cplx_buf +errchk rt_ripixels, rt_rfpixels, rt_rcpixels + +begin + call smark (sp) + + switch (format) { + case INT_FORM: + call salloc (dbl_buf, npix, TY_DOUBLE) + call rt_ripixels (tf, Memd[dbl_buf], npix) + call achtdl (Memd[dbl_buf], Meml[bufptr], npix) + case FP_FORM: + call salloc (dbl_buf, npix, TY_DOUBLE) + call rt_rfpixels (tf, Memd[dbl_buf], npix) + call achtdl (Memd[dbl_buf], Meml[bufptr], npix) + case CPX_FORM: + call salloc (cplx_buf, npix, TY_COMPLEX) + call rt_rcpixels (tf, Memx[cplx_buf], npix) + call achtxl (Memx[cplx_buf], Meml[bufptr], npix) + } + + call sfree (sp) +end + + +# RT_OUTPUT_LINED -- Put line of double pixels to image from text file. + +procedure rt_output_lined (tf, format, bufptr, npix) + +int tf # File descriptor for input text file +int format # Format of pixels in text file (integer/ floating) +pointer bufptr # Pointer to image line to be filled +int npix # Number of pixels per image line + +pointer sp, cplx_buf +errchk rt_ripixels, rt_rfpixels, rt_rcpixels + +begin + call smark (sp) + + switch (format) { + case INT_FORM: + call rt_ripixels (tf, Memd[bufptr], npix) + case FP_FORM: + call rt_rfpixels (tf, Memd[bufptr], npix) + case CPX_FORM: + call salloc (cplx_buf, npix, TY_COMPLEX) + call rt_rcpixels (tf, Memx[cplx_buf], npix) + call achtxd (Memx[cplx_buf], Memd[bufptr], npix) + } + + call sfree (sp) +end + + +# RT_OUTPUT_LINEX -- Put line of complex pixels to image from text file. + +procedure rt_output_linex (tf, format, bufptr, npix) + +int tf # File descriptor for input text file +int format # Format of pixels in text file (integer/ floating) +pointer bufptr # Pointer to image line to be filled +int npix # Number of pixels per image line + +pointer sp, dbl_buf +errchk rt_ripixels, rt_rfpixels, rt_rcpixels + +begin + call smark (sp) + + switch (format) { + case INT_FORM: + call salloc (dbl_buf, npix, TY_DOUBLE) + call rt_ripixels (tf, Memd[dbl_buf], npix) + call achtdx (Memd[dbl_buf], Memx[bufptr], npix) + case FP_FORM: + call salloc (dbl_buf, npix, TY_DOUBLE) + call rt_rfpixels (tf, Memd[dbl_buf], npix) + call achtdx (Memd[dbl_buf], Memx[bufptr], npix) + case CPX_FORM: + call rt_rcpixels (tf, Memx[bufptr], npix) + } + + call sfree (sp) +end + + +# RT_RIPIXELS -- read integer pixels free format from text file into a +# type double real buffer. + +procedure rt_ripixels (tf, dbl_out, npix) + +int tf # File descriptor for input text file +double dbl_out[ARB] # Output pixel array +int npix # Number of pixels to output + +bool neg +int i, sum, ip_start, ip +char text_buf[SZ_LINE] +common /rpix_init/ ip, text_buf +int getline() +errchk getline + +begin + # Read values until satisfied + for (i=0; i < npix; ) { + sum = 0 + + # Position to first non white space character + while (IS_WHITE (text_buf[ip])) + ip = ip + 1 + ip_start = ip + + neg = (text_buf[ip] == '-') + if (neg) + ip = ip + 1 + + while (IS_DIGIT (text_buf[ip])) { + sum = sum * 10 + TO_INTEG (text_buf[ip]) + ip = ip + 1 + } + + if (ip == ip_start) { + if (getline (tf, text_buf) == EOF) { + call eprintf ("Premature EOF seen by rt_ripixels\n") + break + } + ip = 1 + + } else { + i = i + 1 + if (neg) + dbl_out[i] = double (-sum) + else + dbl_out[i] = double ( sum) + } + } +end + + +# RT_RFPIXELS -- read floating point pixels free format from text file into a +# double floating point buffer. + +procedure rt_rfpixels (tf, dbl_out, npix) + +int tf # File descriptor for text file +double dbl_out[npix] # Output pixel buffer +int npix # Number of pixels to output + +int i, nchars +double dval +int gctod(), getline() + +int ip +char text_buf[SZ_LINE] +common /rpix_init/ ip, text_buf +errchk gctod, getline + +begin + # Read values until satisfied + for (i=0; i < npix; ) { + nchars = gctod (text_buf, ip, dval) + + if (nchars == 0) { + if (getline (tf, text_buf) == EOF) { + call eprintf ("Premature EOF seen in rt_rfpixels\n") + break + } + ip = 1 + + } else { + i = i + 1 + dbl_out[i] = dval + } + } +end + + +# RT_RCPIXELS -- read complex pixels free format from text file into a +# complex floating point buffer. + +procedure rt_rcpixels (tf, cplx_out, npix) + +int tf # File descriptor for text file +complex cplx_out[npix] # Output pixel buffer +int npix # Number of pixels to output + +int i, nchars +complex xval +int gctox(), getline() + +int ip +char text_buf[SZ_LINE] +common /rpix_init/ ip, text_buf +errchk gctox, getline + +begin + # Read values until satisfied + for (i=0; i < npix; ) { + nchars = gctox (text_buf, ip, xval) + + if (nchars == 0) { + if (getline (tf, text_buf) == EOF) { + call eprintf ("Premature EOF seen in rt_rcpixels\n") + break + } + ip = 1 + + } else { + i = i + 1 + cplx_out[i] = xval + } + } +end + + +# RT_SKIP_LINES -- Skip lines of text file. + +int procedure rt_skip_lines (tf, nskip) + +int tf # File descriptor of text file +int nskip # Number of lines to skip + +pointer sp, buffer +int i +int fscan() + +begin + call smark (sp) + call salloc (buffer, SZ_LINE, TY_CHAR) + + for (i = 1; i <= nskip; i = i + 1) { + if (fscan (tf) == EOF) { + call sfree (sp) + return (EOF) + } else + call gargstr (Memc[buffer], SZ_LINE) + } + + call sfree (sp) + return (OK) +end diff --git a/pkg/dataio/imtext/t_rtextimage.x b/pkg/dataio/imtext/t_rtextimage.x new file mode 100644 index 00000000..603e9134 --- /dev/null +++ b/pkg/dataio/imtext/t_rtextimage.x @@ -0,0 +1,109 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imtext.h" + +# T_RTEXTIMAGE -- Read text files into IRAF images. Information +# about the dimensionality of the image (the number of dimensions and the +# length of each dimension) must either be read from a FITS header or supplied +# by the user. + +procedure t_rtextimage () + +char output[SZ_FNAME], text_file[SZ_FNAME], temp[SZ_FNAME] +char out_fname[SZ_FNAME] +pointer im +int header, pixels, nskip, nfiles, ntext, format, data_type, tf, i, input +int fd_dim, junk, ndim, ip + +bool clgetb() +#char clgetc() +pointer immap() +int btoi(), clgeti(), clpopni(), clplen(), clgfil(), get_data_type() +int open(), rt_skip_lines(), clpopnu(), ctoi() + +begin + # Determine the input and output file names + input = clpopni ("input") + call clgstr ("output", output, SZ_FNAME) + + # Get hidden parameters from cl. + # data_type = get_data_type (clgetc ("otype")) + call clgstr ("otype", out_fname, SZ_FNAME) + data_type = get_data_type (out_fname[1]) + header = btoi (clgetb ("header")) + pixels = btoi (clgetb ("pixels")) + if (header == NO) + nskip = clgeti ("nskip") + + # Loop over the input files, generating an output name and processing. + nfiles = clplen (input) + do ntext = 1, nfiles { + if (clgfil (input, text_file, SZ_FNAME) == EOF) + return + tf = open (text_file, READ_ONLY, TEXT_FILE) + if (nfiles > 1) { + call sprintf (out_fname, SZ_FNAME, "%s.%03d") + call pargstr (output) + call pargi (ntext) + } else + call strcpy (output, out_fname, SZ_FNAME) + + im = immap (out_fname, NEW_IMAGE, 0) + + # Initialize those values that could be read from the header. + format = UNSET + IM_NDIM(im) = UNSET + IM_PIXTYPE(im) = UNSET + + if (header == YES) { + iferr (call rt_rheader (tf, im, format)) + call erract (EA_FATAL) + } else if (nskip > 0) { + if (rt_skip_lines (tf, nskip) == EOF) + call error (1, "Unexpected EOF when skipping lines") + } + + # Get data_type of output image. If supplied by user, use parameter + # value over anything read from FITS header. + + if (IM_PIXTYPE(im) == UNSET) { + # Not read from header, use parameter value if supplied. + # Otherwise, wait until pixels are read to set pixel type. + if (data_type == ERR) + IM_PIXTYPE(im) = UNSET + else + IM_PIXTYPE(im) = data_type + } else if (data_type != ERR) + # Available in header, but user has specified value to be used + IM_PIXTYPE(im) = data_type + + # If image dimension information wasn't read from header, the user + # must supply it. + + if (IM_NDIM(im) == UNSET) { + fd_dim = clpopnu ("dim") + ndim = clplen (fd_dim) + do i = 1, ndim { + junk = clgfil (fd_dim, temp, SZ_FNAME) + ip = 1 + junk = ctoi (temp, ip, IM_LEN (im, i)) + } + IM_NDIM(im) = ndim + call clpcls (fd_dim) + } + + # Convert text pixels to image pixels, posting only a warning + # message if an error occurs. Processing continues to the next + # file in the input list. + + iferr (call rt_convert_pixels (tf, im, format, pixels)) + call erract (EA_WARN) + + call imunmap (im) + call close (tf) + } + + call clpcls (input) +end diff --git a/pkg/dataio/imtext/t_wtextimage.x b/pkg/dataio/imtext/t_wtextimage.x new file mode 100644 index 00000000..8860f3d6 --- /dev/null +++ b/pkg/dataio/imtext/t_wtextimage.x @@ -0,0 +1,261 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "imtext.h" + +define SZ_FORMAT 20 + + +# WTEXTIMAGE -- Write a text file from an IRAF image. Image header information +# is written in the "keyword = value / comment" format of FITS. Pixel values +# follow the header. The resulting text file can be read as a FITS image. The +# header cards include "NAXIS = 0", indicating no binary data matrix is written. +# The encoded pixel values can be read as special records following the null +# data matrix. + +procedure t_wtextimage () + +bool header +bool pixels +pointer im +char output[SZ_FNAME], format[SZ_FORMAT], imlist[SZ_LINE] +char image[SZ_FNAME], out_fname[SZ_FNAME] +int maxll, file_num, out, input, nfiles + +pointer immap() +bool clgetb(), strne() +int clgeti(), imtgetim(), open(), imtopen(), fstati(), imtlen() + +begin + # Open template of input image filenames. + call clgstr ("input", imlist, SZ_LINE) + input = imtopen (imlist) + nfiles = imtlen (input) + + # See if STDOUT has been redirected and get output filename. + if (fstati (STDOUT, F_REDIR) == YES) { + # Output has been redirected, set output filename to STDOUT + call strcpy ("STDOUT", output, SZ_FNAME) + } else { + # Get output filename from cl + call clgstr ("output", output, SZ_FNAME) + } + + # Get other parameters from cl. + header = clgetb ("header") + pixels = clgetb ("pixels") + maxll = min (MAX_LENTEXT, clgeti ("maxlinelen")) + if (maxll <= 0) + call error (1, "Illegal maximum line length: must be > 0") + + call clgstr ("format", format, SZ_FORMAT) + call strlwr (format) + + file_num = 0 + + while (imtgetim (input, image, SZ_FNAME) != EOF) { + file_num = file_num + 1 + + # Open image. + iferr (im = immap (image, READ_ONLY, 0)) { + call erract (EA_WARN) + next + } + + if (nfiles > 1 && strne (output, "STDOUT")) { + # Generate unique output file name + call sprintf (out_fname, SZ_FNAME, "%s.%03d") + call pargstr (output) + call pargi (file_num) + } else + call strcpy (output, out_fname, SZ_FNAME) + + # Open output file. + iferr (out = open (out_fname, APPEND, TEXT_FILE)) { + call imunmap (im) + call erract (EA_WARN) + next + } + + iferr (call wti_convert_image (im,image,out,header,pixels, + maxll,format)) + call erract (EA_WARN) + + call imunmap (im) + call close (out) + } + + call imtclose (input) +end + + +# WTI_CONVERT_IMAGE -- called once for each image to be converted. This +# procedure determines the output pixel format and then directs the processing +# depending on user request. + +procedure wti_convert_image (im, image, out, header, pixels, maxll, user_format) + +pointer im # input image +char image[ARB] # image name +int out # output text file descriptor +bool header # convert header information (y/n)? +bool pixels # convert pixels (y/n)? +int maxll # maximum line length of text file +char user_format[ARB] # output format for single pixel entered by user + +int width, decpl, fmtchar +pointer sp, out_format, ftn_format, spp_format, ep +errchk wti_determine_fmt, wti_write_header +errchk wti_putint, wti_putreal, wti_putcomplex + +begin + call smark (sp) + call salloc (out_format, SZ_FORMAT, TY_CHAR) + call salloc (spp_format, SZ_FORMAT, TY_CHAR) + call salloc (ftn_format, SZ_FORMAT, TY_CHAR) + call salloc (ep, SZ_LINE, TY_CHAR) + + # Clear the format variables. + call aclrc (Memc[out_format], SZ_FORMAT) + call aclrc (Memc[spp_format], SZ_FORMAT) + call aclrc (Memc[ftn_format], SZ_FORMAT) + call aclrc (Memc[ep], SZ_LINE) + fmtchar = ' ' + + # Determine the output format. + + if (user_format[1] == EOS) { + # Format has not been set by user. Set appropriate defaults. + switch (IM_PIXTYPE(im)) { + case TY_USHORT: + call strcpy ("6d", Memc[spp_format], SZ_FORMAT) + case TY_SHORT: + call strcpy ("7d", Memc[spp_format], SZ_FORMAT) + case TY_INT: + call strcpy ("12d", Memc[spp_format], SZ_FORMAT) + case TY_LONG: + call strcpy ("12d", Memc[spp_format], SZ_FORMAT) + case TY_REAL: + call strcpy ("14.7g", Memc[spp_format], SZ_FORMAT) + case TY_DOUBLE: + call strcpy ("22.15g", Memc[spp_format], SZ_FORMAT) + case TY_COMPLEX: + call strcpy ("21.7z", Memc[spp_format], SZ_FORMAT) + } + } else + call strcpy (user_format, Memc[spp_format], SZ_FORMAT) + + call wti_determine_fmt (Memc[spp_format], Memc[ftn_format], + decpl, fmtchar, width) + + # Write the header. + if (header) { + if (width > 0) { + if ((maxll / width) < 1) { + call sprintf (Memc[ep], SZ_LINE, + "%s: output maxlinelen=%d is too short for format %s") + call pargstr (image) + call pargi (maxll) + call pargstr (Memc[ftn_format]) + call error (2, Memc[ep]) + } + + call sprintf (Memc[out_format], SZ_FORMAT, "%d%s") + call pargi (maxll / width) + call pargstr (Memc[ftn_format]) + } else + call strcpy ("*", Memc[out_format], SZ_FORMAT) + + call wti_write_header (im, image, out, Memc[out_format]) + } + + # Write out the pixels in text form. + if (pixels) { + switch (fmtchar) { + case 'd': + call wti_putint (im, out, maxll, width) + case 'e', 'f', 'g': + call wti_putreal (im, out, maxll, decpl, fmtchar, width) + case 'z': + call wti_putcomplex (im, out, maxll, decpl, 'e', width) + } + } + + call sfree (sp) +end + + +# WTI_DETERMINE_FMT -- Extract field width from input format string and +# generate a fortran format equivalent to the input spp format. The input +# format may be either a Fortran sytle format or an SPP format. + +procedure wti_determine_fmt (spp_format, ftn_format, decpl, fmtchar, width) + +char spp_format[ARB] # SPP format of each pixel +char ftn_format[ARB] # equivalent Fortran format (output) +int decpl # number of decimal places of precision (output) +int fmtchar # format character (output) +int width # field width (output) + +int ip +bool fortran_format +int ctoi() + +begin + # Parse either an SPP format "W.Dc" or a Fortran format "cW.D" to + # determine the field width, number of decimal places or precision, + # and the format char. If the field width is missing or zero we set + # width=0 to flag that free format output is desired. + + for (ip=1; IS_WHITE (spp_format[ip]); ip=ip+1) + ; + fortran_format = IS_ALPHA (spp_format[ip]) + if (fortran_format) { + if (spp_format[ip] == 'i') + fmtchar = 'd' + ip = ip + 1 + } + + # Extract W and D fields. + if (ctoi (spp_format, ip, width) == 0) + width = 0 + if (spp_format[ip] == '.') { + ip = ip + 1 + if (ctoi (spp_format, ip, decpl) == 0) + decpl = 0 + } else + decpl = 0 + + if (!fortran_format && spp_format[ip] != EOS) { + fmtchar = spp_format[ip] + ip = ip + 1 + } + + if (spp_format[ip] != EOS) + call error (3, "unacceptable numeric format") + + # Construct the FTN version of the spp_format. This will be + # output in the header. + + switch (fmtchar) { + case 'd': + call sprintf (ftn_format, SZ_FORMAT, "I%d") + call pargi (width) + case 'e', 'f', 'g': + call sprintf (ftn_format, SZ_FORMAT, "%c%d.%d") + call pargi (TO_UPPER (fmtchar)) + call pargi (width) + call pargi (decpl) + case 'z': + # Tell Fortran to use a list directed read to read complex data. + call strcpy ("*", ftn_format, SZ_FORMAT) + width = 0 + + default: + call error (4, "Improper format. Must be chosen from [defgz].") + } +end diff --git a/pkg/dataio/imtext/wtextimage.semi b/pkg/dataio/imtext/wtextimage.semi new file mode 100644 index 00000000..4574722a --- /dev/null +++ b/pkg/dataio/imtext/wtextimage.semi @@ -0,0 +1,91 @@ +# Semicode for the IRAF image to text file converter. + +procedure t_wtextimage (input, output) + +begin + input = expand template of input image file names + if (output hasn't been redirected) + get name of output file from cl + + # Get hidden parameters from cl + header = is header to be written? + maxlinelen = max number of characters per line of text + if (format not user specified) + format = NOT_SET + + for (each file name in input) { + im = open image file + generate output file name + text = open text file + call convert_image (im, text, header, maxlinelen, format) + close image file + close text file + } +end + + +# CONVERT_IMAGE -- called once for each image to be converted. Directs +# the processing depending on user request. + +procedure convert_image (im, text, header, maxlinelen, format) + +begin + if (format = NOT_SET) + format = appropriate value for data type of image + + # Calculate number of pixels per line of text + npix_line = maxlinelen / (field width of pixel output format) + output_format = "npix_line.pixel_format" + + if (header is to be written) + call write_header (im, text, output_format, maxlinelen) + + call convert_pixels (im, text, output_format) +end + + +# WRITE_HEADER -- write information from IRAF image header in +# "keyword = value" format, one keyword per line of text. + +procedure convert_header (image, text, output_format, maxlinelen) + +begin + # Write header information to text file + SIMPLE = T + BITPIX = 8 + NAXIS = 0 + ORIGIN = NOAO + IRAF-MAX= IM_MAX + IRAF-MIN= IM_MIN + IRAF-B/P= + IRAFTYPE= + OBJECT = IM_TITLE + NDIM = IM_NDIM + LEN1 = IM_LEN(1) + FILENAME= IM_HDRFILE + FORMAT = output_format + + # Write any information stored in image user area + if (user area contains information) { + COMMENT = "Copying user area" + KEYWORD = copy user area to text file + } + + # Final header line is END + END = last line of header + + Pad with blank lines until multiple of 36 lines is output +end + + +# CONVERT_IMAGE -- write pixel values from IRAF image into text file. The +# pixels are output in "leftmost subscript varying most rapidly" order. + +procedure convert_image (image, text, format) + +begin + get next line of image + for each pixel in line + convert pixel to character + put out line to text file according to format +end diff --git a/pkg/dataio/imtext/wti_wheader.x b/pkg/dataio/imtext/wti_wheader.x new file mode 100644 index 00000000..2cad585d --- /dev/null +++ b/pkg/dataio/imtext/wti_wheader.x @@ -0,0 +1,152 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imtext.h" + +define NBITS_ASCII 8 +define NDEC_PLACES 7 + + +# WTI_WRITE_HEADER -- write information from IRAF image header to text file in +# FITS "keyword = value / comment" format. One keyword is written per line +# of text. + +procedure wti_write_header (im, image, tx, out_format) + +pointer im # Pointer to image file +char image[ARB] # Image filename +int tx # File descriptor of text file +char out_format[ARB] # Output format for pixel conversion + +int i, nlines, user, op, max_lenuser +pointer sp, root, line, comment +bool streq() +int strlen(), sizeof(), getline(), stropen(), gstrcpy(), stridx() + +errchk addcard_b, addcard_i, addcard_r, addcard_st +errchk wti_iraf_type, streq, strupr, stropen, strclose, getline + +begin + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (comment, SZ_LINE, TY_CHAR) + + call addcard_i (tx, "BITPIX", NBITS_ASCII, "8-bit ASCII characters") + call addcard_i (tx, "NAXIS", IM_NDIM(im), "Number of Image Dimensions") + + nlines = NFITS_LINES + + # Construct and output an NAXISn card for each axis + do i = 1, IM_NDIM(im) { + op = gstrcpy ("NAXIS", Memc[root], LEN_KEYWORD) + call sprintf (Memc[root+op], LEN_KEYWORD-op, "%d") + call pargi (i) + call addcard_i (tx, Memc[root], IM_LEN(im,i), "Length of axis") + nlines = nlines + 1 + } + + call addcard_st (tx, "ORIGIN", "NOAO-IRAF: WTEXTIMAGE", "", + strlen("NOAO-IRAF: WTEXTIMAGE")) + + # Add the image MIN and MAX header cards + call strcpy ("Max image pixel", Memc[comment], SZ_LINE) + if (IM_MTIME(im) > IM_LIMTIME(im)) + call strcat (" (out of date)", Memc[comment], SZ_LINE) + call addcard_r (tx, "IRAF-MAX", IM_MAX(im), Memc[comment], + NDEC_PLACES) + + call strcpy ("Min image pixel", Memc[comment], SZ_LINE) + if (IM_MTIME(im) > IM_LIMTIME(im)) + call strcat (" (out of date)", Memc[comment], SZ_LINE) + call addcard_r (tx, "IRAF-MIN", IM_MIN(im), Memc[comment], + NDEC_PLACES) + + # The number of bits per pixel is calculated and output + call addcard_i (tx, "IRAF-B/P", sizeof (IM_PIXTYPE(im)) * + SZB_CHAR * NBITS_BYTE, "Image bits per pixel") + + call wti_iraf_type (IM_PIXTYPE(im), Memc[root]) + call addcard_st (tx, "IRAFTYPE", Memc[root], "Image datatype", + strlen(Memc[root])) + + call strupr (IM_TITLE(im)) + call addcard_st (tx, "OBJECT" , IM_TITLE(im), "", + strlen (IM_TITLE(im))) + + call strupr (image) + call addcard_st (tx, "FILENAME", image, "IRAF filename", + strlen (image)) + nlines = nlines + 1 + + call strcpy ("Text line format", Memc[comment], SZ_LINE) + if (streq (out_format, "*")) + call strcat (" (* = list directed)", Memc[comment], SZ_LINE) + call addcard_st (tx, "FORMAT", out_format, Memc[comment], + LEN_STRING) + nlines = nlines + 1 + + # Write any information stored in image user area + if ((IM_HDRLEN(im) - LEN_IMHDR) > 0) { + max_lenuser = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + user = stropen (Memc[IM_USERAREA(im)], max_lenuser, READ_ONLY) + + while (getline (user, Memc[line]) != EOF) { + call putline (tx, Memc[line]) + nlines = nlines + 1 + } + + # Make sure last line written out included a newline. It won't if + # the user area was truncated when it was read. + if (stridx ("\n", Memc[line]) == 0) + call putline (tx, "\n") + + call close (user) + } + + # Final header line is END (FITS keywords are 8 characters long) + call fprintf (tx, "END%77w\n") + nlines = nlines + 1 + + # Pad output file with blank lines until header block occupies + # a multiple of 36 lines. + + if (nlines != NCARDS_FITS_BLK) { + do i = 1, NCARDS_FITS_BLK - mod(nlines, NCARDS_FITS_BLK) + call fprintf (tx, "%80w\n") + } + + call sfree (sp) +end + + +# WTI_IRAF_TYPE -- Procedure to set the iraf datatype keyword. Permitted strings +# are INTEGER, FLOATING or COMPLEX. + +procedure wti_iraf_type (datatype, type_str) + +int datatype # the IRAF data type +char type_str[ARB] # the output IRAF type string + +begin + switch (datatype) { + case TY_SHORT: + call strcpy ("SHORT INTEGER", type_str, LEN_STRING) + case TY_USHORT: + call strcpy ("UNSIGNED SHORT INT", type_str, LEN_STRING) + case TY_INT: + call strcpy ("INTEGER", type_str, LEN_STRING) + case TY_LONG: + call strcpy ("LONG INTEGER", type_str, LEN_STRING) + case TY_REAL: + call strcpy ("REAL FLOATING", type_str, LEN_STRING) + case TY_DOUBLE: + call strcpy ("DOUBLE FLOATING", type_str, LEN_STRING) + case TY_COMPLEX: + call strcpy ("COMPLEX", type_str, LEN_STRING) + default: + call error (4, "IRAF_TYPE: Unknown IRAF image type.") + } +end diff --git a/pkg/dataio/lib/addcards.x b/pkg/dataio/lib/addcards.x new file mode 100644 index 00000000..42699380 --- /dev/null +++ b/pkg/dataio/lib/addcards.x @@ -0,0 +1,140 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define MAXLEN_STRVAL 65 +define LEN_KEYWORD 8 +define LEN_STRING 18 + +# ADDCARD_R -- Format and append a FITS header card with a real +# keyword value to the input string buffer. + +procedure addcard_r (fd, keyword, value, comment, precision) + +int fd # File descriptor of input string buffer +char keyword[LEN_KEYWORD] # FITS keyword +real value # Value of FITS keyword +char comment[ARB] # Comment string +int precision # Number of decimal places output + + +begin + call fprintf (fd, "%-8.8s= %20.*g / %-45.45s\n") + call pargstr (keyword) + call pargi (precision) + call pargr (value) + call pargstr (comment) +end + + +# ADDCARD_I -- Format and append a FITS header card with an integer +# keyword value to the input string buffer. + +procedure addcard_i (fd, keyword, value, comment) + +int fd # File descriptor of input string buffer +char keyword[LEN_KEYWORD] # FITS keyword +int value # Value of FITS keyword +char comment[ARB] # Comment string + +begin + call fprintf (fd, "%-8.8s= %20d / %-45.45s\n") + call pargstr (keyword) + call pargi (value) + call pargstr (comment) +end + + +# ADDCARD_TIME -- Format and append a FITS header card to the input +# file descriptor. The value is input as a real number; it is output +# in HH:MM:SS.S format with %h. The procedure can be used for RA, DEC +# and ST, UT and HA. + +procedure addcard_time (fd, keyword, value, comment) + +int fd # File descriptor +char keyword[LEN_KEYWORD] # FITS keyword +real value # Value of FITS keyword to be encoded +char comment[ARB] # Comment string + + +begin + call fprintf (fd, "%-8.8s= '%-18.1h' / %-45s\n") + call pargstr (keyword) + call pargr (value) + call pargstr (comment) +end + + +# ADDCARD_ST -- Format and output a FITS header card to the input +# file descriptor. The value is output as a string with the given keyword. +# If the string value is longer than 18 characters, it is output without +# a comment. + +procedure addcard_st (fd, keyword, value, comment, length) + +int fd # File descriptor +char keyword[LEN_KEYWORD] # FITS keyword +char value[SZ_LINE] # String value of FITS keyword to be encoded +char comment[ARB] # Comment string +int length # Length of string value + +begin + if (length <= LEN_STRING) { + call fprintf (fd, "%-8.8s= '%-18.18s' / %-44s\n") + call pargstr (keyword) + call pargstr (value) + call pargstr (comment) + } else { + length = min (length, MAXLEN_STRVAL) + call fprintf (fd, "%-8.8s= '%*.*s' /\n") + call pargstr (keyword) + call pargi (-length) + call pargi (length) + call pargstr (value) + } +end + + +# ADDCARD_B -- Format and output a FITS header card to the input file +# descriptor. The value is output as a boolean with the given keyword. +# Unlike string parameters, booleans are not enclosed in quotes. + +procedure addcard_b (fd, keyword, value, comment) + +int fd # File descriptor +char keyword[LEN_KEYWORD] # FITS keyword +bool value # Boolean parameter (T/F) +char comment[ARB] # Comment string +char truth + +begin + if (value) + truth = 'T' + else + truth = 'F' + + call fprintf (fd, "%-8.8s= %20c / %-45.45s\n") + call pargstr (keyword) + call pargc (truth) + call pargstr (comment) +end + + +# ADDCARD_D -- Format and append a FITS header card with a double +# keyword value to the input string buffer. + +procedure addcard_d (fd, keyword, value, comment, precision) + +int fd # File descriptor of input string buffer +char keyword[LEN_KEYWORD] # FITS keyword +double value # Value of FITS keyword +char comment[ARB] # Comment string +int precision # Number of decimal places output + + +begin + call fprintf (fd, "%-8.8s= %20.*f / %-45.45s\n") + call pargstr (keyword) + call pargi (precision) + call pargd (value) + call pargstr (comment) +end diff --git a/pkg/dataio/lib/getdatatype.x b/pkg/dataio/lib/getdatatype.x new file mode 100644 index 00000000..9502e82f --- /dev/null +++ b/pkg/dataio/lib/getdatatype.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define NTYPES 9 + +# GETDATATYPE -- Convert a character to an IRAF data type + +int procedure getdatatype (ch) + +char ch +int i, type_code[NTYPES] +int stridx() + +string types "bcusilrdx" # Supported data types +data type_code /TY_UBYTE, TY_CHAR, TY_USHORT, TY_SHORT, TY_INT, TY_LONG, + TY_REAL, TY_DOUBLE, TY_COMPLEX/ + +begin + i = stridx (ch, types) + if (i == 0) + return (ERR) + else + return (type_code[stridx(ch,types)]) +end + + +# DTSTRING -- Convert a datatype to a string + +procedure dtstring (datatype, str, maxchar) + +int datatype # IRAF datatype +char str[maxchar] # Output string +int maxchar # Maximum characters in string + +begin + switch (datatype) { + case TY_UBYTE: + call strcpy ("unsigned byte", str, maxchar) + case TY_CHAR: + call strcpy ("character", str, maxchar) + case TY_USHORT: + call strcpy ("unsigned short", str, maxchar) + case TY_SHORT: + call strcpy ("short", str, maxchar) + case TY_INT: + call strcpy ("integer", str, maxchar) + case TY_LONG: + call strcpy ("long", str, maxchar) + case TY_REAL: + call strcpy ("real", str, maxchar) + case TY_DOUBLE: + call strcpy ("double", str, maxchar) + case TY_COMPLEX: + call strcpy ("complex", str, maxchar) + default: + call strcpy ("unknown", str, maxchar) + } +end diff --git a/pkg/dataio/lib/mkpkg b/pkg/dataio/lib/mkpkg new file mode 100644 index 00000000..698997dd --- /dev/null +++ b/pkg/dataio/lib/mkpkg @@ -0,0 +1,12 @@ +# These routines are used by more than one task in the dataio package: + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + addcards.x + #getdatatype.x + #ranges.x + ; diff --git a/pkg/dataio/lib/ranges.x b/pkg/dataio/lib/ranges.x new file mode 100644 index 00000000..b3812cd1 --- /dev/null +++ b/pkg/dataio/lib/ranges.x @@ -0,0 +1,234 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define FIRST 1 # Default starting range +define LAST MAX_INT # Default ending range +define STEP 1 # Default step + +# DECODE_RANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Return as output a list +# of ranges defining a list of numbers, and the count of list numbers. +# Range limits must be positive nonnegative integers. ERR is returned as +# the function value if a conversion error occurs. The list of ranges is +# delimited by a single NULL. + +int procedure decode_ranges (range_string, ranges, max_ranges, nvalues) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int nvalues # The number of values in the ranges + +int ip, nrange, first, last, step, ctoi() + +begin + ip = 1 + nvalues = 0 + + do nrange = 1, max_ranges - 1 { + # Defaults to all positive integers + first = FIRST + last = LAST + step = STEP + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '-', 'x', or EOS. If not return ERR. + if (range_string[ip] == EOS) { # end of list + if (nrange == 1) { + # Null string defaults + ranges[1, 1] = first + ranges[2, 1] = last + ranges[3, 1] = step + ranges[1, 2] = NULL + nvalues = nvalues + abs (last-first) / step + 1 + return (OK) + } else { + ranges[1, nrange] = NULL + return (OK) + } + } else if (range_string[ip] == '-') + ; + else if (range_string[ip] == 'x') + ; + else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, first) == 0) + return (ERR) + } else + return (ERR) + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', or 'x' otherwise last = first. + if (range_string[ip] == 'x') + ; + else if (range_string[ip] == '-') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, last) == 0) + return (ERR) + } else if (range_string[ip] == 'x') + ; + else + return (ERR) + } else + last = first + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, step) == 0) + ; + } else if (range_string[ip] == '-') + ; + else + return (ERR) + } + + # Output the range triple. + ranges[1, nrange] = first + ranges[2, nrange] = last + ranges[3, nrange] = step + nvalues = nvalues + abs (last-first) / step + 1 + } + + return (ERR) # ran out of space +end + + +# GET_NEXT_NUMBER -- Given a list of ranges and the current file number, +# find and return the next file number. Selection is done in such a way +# that list numbers are always returned in monotonically increasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure get_next_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number+1 is anywhere in the list, that is the next number, + # otherwise the next number is the smallest number in the list which + # is greater than number+1. + + number = number + 1 + next_number = MAX_INT + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder + step <= last) + next_number = number - remainder + step + } else if (first > number) + next_number = min (next_number, first) + } + + if (next_number == MAX_INT) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# GET_PREVIOUS_NUMBER -- Given a list of ranges and the current file number, +# find and return the previous file number. Selection is done in such a way +# that list numbers are always returned in monotonically decreasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure get_previous_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number-1 is anywhere in the list, that is the previous number, + # otherwise the previous number is the largest number in the list which + # is less than number-1. + + number = number - 1 + next_number = 0 + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder >= first) + next_number = number - remainder + } else if (last < number) { + remainder = mod (last - first, step) + if (remainder == 0) + next_number = max (next_number, last) + else if (last - remainder >= first) + next_number = max (next_number, last - remainder) + } + } + + if (next_number == 0) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# IS_IN_RANGE -- Test number to see if it is in range. + +bool procedure is_in_range (ranges, number) + +int ranges[ARB] # Range array +int number # Number to be tested against ranges + +int ip, first, last, step + +begin + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) + if (mod (number - first, step) == 0) + return (true) + } + + return (false) +end diff --git a/pkg/dataio/mkpkg b/pkg/dataio/mkpkg new file mode 100644 index 00000000..bba288df --- /dev/null +++ b/pkg/dataio/mkpkg @@ -0,0 +1,33 @@ +# Make the DATAIO package + +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $set LIBS = "-lxtools" + $update libpkg.a + $omake x_dataio.x + $link x_dataio.o libpkg.a $(LIBS) -o xx_dataio.e + ; + +install: + $move xx_dataio.e bin$x_dataio.e + ; + +libpkg.a: + @lib + @export + @import + @imtext + @reblock + @fits + @bintext + @mtexamine + @cardimage + @t2d + ; diff --git a/pkg/dataio/mtexamine.par b/pkg/dataio/mtexamine.par new file mode 100644 index 00000000..07269aa1 --- /dev/null +++ b/pkg/dataio/mtexamine.par @@ -0,0 +1,8 @@ +tape_file,s,a,,,,Tape file +file_list,s,h,1-999,,,List of file numbers +dump_records,b,h,no,,,Dump selected records? +rec_list,s,h,1-999,,,List of records to be dumped +byte_chunk,i,h,1,,,Byte chunk +swapbytes,b,h,no,,,Swap bytes? +output_format,s,h,o,,,Dump format (c|d|o|u|x) +mode,s,h,"ql",,, diff --git a/pkg/dataio/mtexamine/mkpkg b/pkg/dataio/mtexamine/mkpkg new file mode 100644 index 00000000..99e96080 --- /dev/null +++ b/pkg/dataio/mtexamine/mkpkg @@ -0,0 +1,10 @@ +# Mtexamine library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_mtexamine.x mtexamine.com + ; diff --git a/pkg/dataio/mtexamine/mtexamine.com b/pkg/dataio/mtexamine/mtexamine.com new file mode 100644 index 00000000..46969458 --- /dev/null +++ b/pkg/dataio/mtexamine/mtexamine.com @@ -0,0 +1,6 @@ +int dump_records +int byteswap +int byte_chunk +char output_format + +common /mtexam/ dump_records, byteswap, byte_chunk, output_format diff --git a/pkg/dataio/mtexamine/t_mtexamine.x b/pkg/dataio/mtexamine/t_mtexamine.x new file mode 100644 index 00000000..26f7b2fd --- /dev/null +++ b/pkg/dataio/mtexamine/t_mtexamine.x @@ -0,0 +1,376 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +define MAX_RANGES 100 +define LEN_LINE 80 +define TAPE_BYTE 8 +define TWO_TO_EIGHT 256 +define FIELD_INDEX 5 +define NFORMATS 5 + + +# MTEXAMINE -- Examine one or more magtape files, counting the number and size +# of the records in a file, and the number of files on the tape. + +procedure t_mtexamine() + +int nfiles, file_number, ndumps, nrecords +int file_range[2*MAX_RANGES+1], rec_range[2*MAX_RANGES+1] +pointer sp, tape_name, tape_file, file_list, rec_list + +bool clgetb() +char clgetc() +int fstati(), mtfile(), mtneedfileno(), decode_ranges(), get_next_number() +int mt_examine(), mt_get_format(), clgeti(), btoi() +include "mtexamine.com" + +begin + # Allocate working space. + call smark (sp) + call salloc (tape_name, SZ_FNAME, TY_CHAR) + call salloc (tape_file, SZ_FNAME, TY_CHAR) + call salloc (file_list, SZ_LINE, TY_CHAR) + call salloc (rec_list, SZ_LINE, TY_CHAR) + + # Flush STDOUT on a newline only if output is not redirected. + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Get input file(s). + call clgstr ("tape_file", Memc[tape_file], SZ_FNAME) + if (mtfile (Memc[tape_file]) == NO) + call strcpy ("1", Memc[file_list], SZ_LINE) + else if (mtneedfileno (Memc[tape_file]) == NO) + call strcpy ("1", Memc[file_list], SZ_LINE) + else + call clgstr ("file_list", Memc[file_list], SZ_LINE) + if (decode_ranges (Memc[file_list],file_range,MAX_RANGES,nfiles) == ERR) + call error (0, "Illegal file number list.") + + # Get dump parameters + dump_records = btoi (clgetb ("dump_records")) + if (dump_records == YES) { + call clgstr ("rec_list", Memc[rec_list], SZ_LINE) + if (decode_ranges (Memc[rec_list], rec_range, MAX_RANGES, + ndumps) == ERR) + call error (0, "Illegal record list.") + byteswap = btoi (clgetb ("swapbytes")) + byte_chunk = clgeti ("byte_chunk") + if (byte_chunk < 1 || byte_chunk > (SZ_LONG * SZB_CHAR)) + call error (0, "Illegal byte chunk size.") + output_format = mt_get_format (clgetc ("output_format")) + if (output_format == ERR) + call error (0, "Illegal format.") + if (byte_chunk != 1 && output_format == FMT_CHAR) + call error (0, "Cannot output integers as chars.") + } + + # Loop over files + file_number = 0 + while (get_next_number (file_range, file_number) != EOF) { + + if (mtfile (Memc[tape_file]) == YES && + mtneedfileno (Memc[tape_file]) == YES) + call mtfname (Memc[tape_file], file_number, Memc[tape_name], + SZ_FNAME) + else + call strcpy (Memc[tape_file], Memc[tape_name], SZ_FNAME) + + iferr { + nrecords = mt_examine (Memc[tape_name], rec_range) + } then { + call eprintf ("Error reading file: %s\n") + call pargstr (Memc[tape_name]) + call erract (EA_WARN) + break + } else if (nrecords == 0) { + call printf ("Tape at EOT\n") + break + } + + } + + call sfree (sp) +end + + +# MT_EXAMINE -- Procedure to examine a tape file. If dump_record is +# no mtexamine gives a summary of the record structure of the file, +# otherwise the specified records are dumped. + +int procedure mt_examine (tape_file, dump_range) + +char tape_file[ARB] # input file name +int dump_range[ARB] # range of records to be dumped + +pointer sp, inbuf, pchar, junk +int in, bufsize, totrecords, nrecords, totbytes, last_recsize, nbadrec +int stat, rec_number, next_dump, recsize, nelems, vals_per_line, field_len +long maxval, max_plusint, twice_max_plusint + +int mtopen(), fstati(), get_next_number(), read(), gltoc() +errchk mtopen, malloc, read, mfree, close +include "mtexamine.com" + +begin + call smark (sp) + call salloc (junk, SZ_FNAME, TY_CHAR) + + in = mtopen (tape_file, READ_ONLY, 0) + bufsize = fstati (in, F_BUFSIZE) + call salloc (pchar, bufsize, TY_CHAR) + + call printf ("File %s:\n") + call pargstr (tape_file) + + totrecords = 0 + nrecords = 0 + totbytes = 0 + nbadrec = 0 + last_recsize = 0 + + # Prepare formatting parameters for dumping records. + if (dump_records == YES) { + call salloc (inbuf, bufsize * SZB_CHAR, TY_LONG) + rec_number = 0 + next_dump = get_next_number (dump_range, rec_number) + maxval = 2 ** (byte_chunk * TAPE_BYTE - 1) - 1 + field_len = gltoc (maxval, Memc[junk], SZ_FNAME, TAPE_BYTE) + 1 + vals_per_line = (LEN_LINE - FIELD_INDEX) / (field_len + 1) + if (output_format == FMT_DECIMAL && byte_chunk > 1 && + byte_chunk < (SZ_LONG * SZB_CHAR)) { + max_plusint = maxval + 1 + twice_max_plusint = 2 * max_plusint + } + } + + # Loop through the records. + repeat { + iferr (stat = read (in, Memc[pchar], bufsize)) { + call fseti (in, F_VALIDATE, last_recsize / SZB_CHAR) + nbadrec = nbadrec + 1 + call printf ("\tRead error on record: %d\n") + call pargi (totrecords + 1) + stat = read (in, Memc[pchar], bufsize) + } + if (stat == EOF) + break + + recsize = fstati (in, F_SZBBLK) + if (dump_records == NO) { + if (nrecords == 0) { + nrecords = 1 + last_recsize = recsize + } else if (recsize == last_recsize) { + nrecords = nrecords + 1 + } else { + call printf ("\t%d %d-byte records\n") + call pargi (nrecords) + call pargi (last_recsize) + nrecords = 1 + last_recsize = recsize + } + } else if (next_dump != EOF && rec_number == totrecords + 1) { + call printf (" Record %d,") + call pargi (totrecords + 1) + call printf (" %d bytes,") + call pargi (recsize) + nelems = recsize / byte_chunk + call printf (" %d elements") + call pargi (nelems) + call mt_bytupkl (Memc[pchar], Meml[inbuf], recsize, byte_chunk, + byteswap) + call mt_dump (Meml[inbuf], nelems, field_len, vals_per_line, + max_plusint, twice_max_plusint) + next_dump = get_next_number (dump_range, rec_number) + } + + totrecords = totrecords + 1 + totbytes = totbytes + recsize + } + + if (nrecords > 0 && dump_records == NO) { + call printf ("\t%d %d-byte records\n") + call pargi (nrecords) + call pargi (last_recsize) + } + + # Print total number of records and bytes + if (dump_records == YES) { + call printf (" Total %d records, %d bytes\n") + call pargi (totrecords) + call pargi (totbytes) + } else { + call printf ("\tTotal %d records, %d bytes") + call pargi (totrecords) + call pargi (totbytes) + if (nbadrec > 0) { + call printf (" [%d bad records]") + call pargi (nbadrec) + } + call printf ("\n") + } + + call close (in) + + call sfree (sp) + return (totrecords) +end + + +# MT_DUMP -- Procedure to format and dump a tape record in chars, shorts or +# longs in char, decimal, octal, unsigned decimal or hexadecimal format. + +procedure mt_dump (buffer, nelems, field_len, vals_per_line, max_plusint, + twice_max_plusint) + +int nelems, field_len, vals_per_line +long buffer[ARB], max_plusint, twice_max_plusint + +int i, nchars +char ch, outstr[SZ_FNAME] +int ctocc() +include "mtexamine.com" + +begin + for (i = 1; i <= nelems; i = i + 1) { + if (mod (i, vals_per_line) == 1) { + call printf ("\n%*d:") + call pargi (FIELD_INDEX) + call pargi (i) + } + if (output_format == FMT_CHAR) { + ch = buffer[i] + nchars = ctocc (ch, outstr, SZ_FNAME) + call printf ("%*s") + call pargi (field_len) + call pargstr (outstr) + } else { + if (output_format == FMT_DECIMAL && byte_chunk > 1 + && byte_chunk < (SZ_LONG * SZB_CHAR)) + call mt_sign_convert (buffer[i], 1, max_plusint, + twice_max_plusint) + call printf ("%**") + call pargi (field_len) + call pargc (output_format) + call pargl (buffer[i]) + } + } + + call printf ("\n") +end + + +# MT_GET_FORMAT -- Procedure to return the appropriate output format. + +int procedure mt_get_format (c) + +char c +int i, format_code[NFORMATS] +int stridx() +string formats "cdoxu" +data format_code /FMT_CHAR, FMT_DECIMAL, FMT_OCTAL, FMT_HEX, FMT_UNSIGNED/ + +begin + i = stridx (c, formats) + if ( i == 0) + return (ERR) + else + return (format_code[i]) +end + + +# MT_BYTUPKL -- Procedure to unpack an array in chunks byte_chunk bytes long +# into a long array with optional byteswapping. + +procedure mt_bytupkl (a, b, nbytes, byte_chunk, byteswap) + +char a[ARB] # input buffer +long b[ARB] # output array +int nbytes # number of bytes +int byte_chunk # number of bytes to be formatted, swapped etc. +int byteswap # swap bytes + +int op, i, j, rem +long sum + +begin + op = 1 + + # Unpack unsigned bytes into a long integer array + call achtbl (a, b, nbytes) + + # Flip bytes if necessary + if (byteswap == YES && byte_chunk > 1) { + for (i = 1; i <= nbytes - byte_chunk + 1; i = i + byte_chunk) + call mt_aflipl (b[i], byte_chunk) + } + + # Convert the bytes into unsigned integers + for (i = 1; i <= nbytes - byte_chunk + 1; i = i + byte_chunk) { + sum = 0 + for (j = 1; j <= byte_chunk; j = j + 1) { + sum = sum + TWO_TO_EIGHT ** (byte_chunk - j) * + b[i + j - 1] + } + b[op] = sum + op = op + 1 + } + + # Convert remaining bytes + rem = nbytes - i + 1 + if (rem > 0) { + if (byteswap == YES && byte_chunk > 1) + call mt_aflipl (b[i], rem) + sum = 0 + for (j = 1; j <= rem; j = j + 1) + sum = sum + TWO_TO_EIGHT ** (rem - j) * + b[i + j - 1] + b[op] = sum + } +end + + +# MT_AFLIPL -- Procedure to flip a long integer array in place. + +procedure mt_aflipl (buf, npix) + +long buf[npix] # array to be flipped +int npix # number of elements in array + +int n_total, n_half, i, j + +begin + n_half = npix / 2 + n_total = npix + 1 + for (i = 1; i <= n_half; i = i + 1) { + j = buf[i] + buf[i] = buf[n_total - i] + buf[n_total - i] = j + } +end + + +# MT_SIGN_CONVERT -- Procedure to convert unsigned long integers in the range +# 0 to twice_max_plusint - 1 to integers in the range - max_plusint +# to max_plusint - 1. + +procedure mt_sign_convert (b, nelems, max_plusint, twice_max_plusint) + +long b[nelems] # array of long integers to be converted +int nelems # number of elements in the array +long max_plusint # 0 <= b[i] <= max_plusint - 1 +long twice_max_plusint # twice max_plusint + +int i + +begin + for (i = 1; i <= nelems; i = i + 1) { + if (b[i] >= max_plusint) + b[i] = b[i] - twice_max_plusint + } +end diff --git a/pkg/dataio/rcardimage.par b/pkg/dataio/rcardimage.par new file mode 100644 index 00000000..98276eed --- /dev/null +++ b/pkg/dataio/rcardimage.par @@ -0,0 +1,14 @@ +mode,s,h,"ql" +cardfile,s,a,,,,"Card image file" +file_list,s,a,,,,"List of tape file numbers" +textfile,s,a,,,,"Output file text file(s)" +card_length,i,h,80,,,"Columns per card" +max_line_length,i,h,161,,161,"Maximum line length" +entab,b,h,yes,,,"Replace blanks with tabs and blanks?" +join,b,a,no,,,"Join oversize lines?" +contn_string,s,a,>>,,,"Continuation line marker" +trim,b,h,yes,,,"Trim trailing whitespace?" +verbose,b,h,yes,,,"Print messages?" +ebcdic,b,h,no,,,"Convert from EBCDIC to ASCII?" +ibm,b,h,no,,,"Translate from IBM(EBCDIC) to ASCII?" +offset,i,h,0,,,Tape file number offset diff --git a/pkg/dataio/reblock.par b/pkg/dataio/reblock.par new file mode 100644 index 00000000..01916973 --- /dev/null +++ b/pkg/dataio/reblock.par @@ -0,0 +1,16 @@ +infiles,s,a,,,,Input file +outfiles,s,a,,,,Output file +file_list,s,a,,,,Tape file list +newtape,b,a,,,,Blank tape? +outblock,i,h,INDEF,,,Size of output block in bytes +inrecord,i,h,INDEF,,,Size of input records in bytes +outrecord,i,h,INDEF,,,Size of output records in btyes +pad_block,b,h,no,,,Pad last block? +padchar,s,h,'0',,,Pad character +skipn,i,h,0,,,Skip n blocks (tape) or records (disk) +copyn,i,h,INDEF,,,Copy n blocks (tape) or records (disk) +byteswap,b,h,no,,,Swap bytes? +wordswap,b,h,no,,,Swap words? +offset,i,h,0,,,Tape file number offset +verbose,b,h,yes,,,Print messages? +mode,s,h,"ql",,, diff --git a/pkg/dataio/reblock/mkpkg b/pkg/dataio/reblock/mkpkg new file mode 100644 index 00000000..5baf1a30 --- /dev/null +++ b/pkg/dataio/reblock/mkpkg @@ -0,0 +1,12 @@ +# Reblock Library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_reblock.x reblock.com reblock.h \ + + reblock_file.x reblock.com reblock.h + ; diff --git a/pkg/dataio/reblock/reblock.com b/pkg/dataio/reblock/reblock.com new file mode 100644 index 00000000..35bc652d --- /dev/null +++ b/pkg/dataio/reblock/reblock.com @@ -0,0 +1,21 @@ +# input parameters +int szb_outblock # size of output block in bytes +int szb_inrecord # size of input record in bytes +int szb_outrecord # size of output record in bytes +int nskip # number blocks (tape) or records (disk) to be skipped +int ncopy # number of blocks (tape) or records (disk) to be copied +int padvalue # integer value of padcharacter + +# integer switches +int intape # input tape device +int outtape # output tape device +int reblock # reformat? +int pad_block # pad short blocks +int pad_record # pad records +int trim_record # trim records +int byteswap # swap every other byte +int wordswap # swap every other word + +common /reblock/ szb_outblock, szb_inrecord, szb_outrecord, nskip, ncopy, + padvalue, intape, outtape, reblock, pad_block, pad_record, + trim_record, byteswap, wordswap diff --git a/pkg/dataio/reblock/reblock.h b/pkg/dataio/reblock/reblock.h new file mode 100644 index 00000000..c88d38a8 --- /dev/null +++ b/pkg/dataio/reblock/reblock.h @@ -0,0 +1,7 @@ +# define the output parameters +define BLKS_RD $1[1] +define BLKS_WRT $1[2] +define RECS_RD $1[3] +define RECS_WRT $1[4] +define LEN_OUTPARAM 4 + diff --git a/pkg/dataio/reblock/reblock.hlp b/pkg/dataio/reblock/reblock.hlp new file mode 100644 index 00000000..465314be --- /dev/null +++ b/pkg/dataio/reblock/reblock.hlp @@ -0,0 +1,154 @@ +.help reblock Mar84 dataio +.ih +NAME +reblock -- copy a file on tape or disk with optional reblocking +.ih +USAGE +reblock (infiles, outfiles, file_list) +.ih +PARAMETERS +.ls infiles +File or device name e.g. "mta1600[2]" or "mta800" or "file1". +.le +.ls outfiles +If multiple file to disk is requested, the ouput file names will be generated +by concatenating the tape file number onto the output file name. +.le +.ls file_list +List of tape file numbers or ranges delimited by whitespace or commas, +e.g. "1-3, 5_8". +File_list is requested only if the magtape input device is specified. +Files will be read in ascending order regardless of the ordering of the list. +Reading will terminate silently if EOT is reached, thus a list such as +"1-999" may be used to read all files on the tape. +.le +.ls newtape +If the output device is magtape, newtape specifies whether the tape is +blank or contains data. +Newtape is requested only if no tape file number is specified, e.g. "mta1600". +.le +.ls outblock = INDEF +Size of the output block bytes. +In the default case and for disk output, the output block size is set to the +file i/o disk default buffer size. +.le +.ls inrecord = INDEF, outrecord = INDEF +The sizes of the input and output logical records in bytes. +The default input and output record sizes are set equal to +the input and output block sizes respectively. If inrecord > outrecord, +records are trimmed; if inrecord < outrecord, records are padded; if +inrecord = outrecord, records are simply counted. If only one of inrecord or +outrecord is set, the undefined parameter defaults to the value of the +other. +.le +.ls nskip = 0 +The number of input blocks (tape input) or records (disk input, size inrecord) +to be skipped. +.le +.ls ncopy = INDEF +The number of input blocks (tape input) or records +(disk input, size inrecord) to be copied. Ncopy defaults to a very large number. +.le +.ls byteswap = no +Swap every other byte. +.le +.ls wordswap = no +Swap every other word. +.le +.ls pad_block = no +If pad_block is set, reblock pads trailing blocks until they are outblock +bytes long, otherwise trailing blocks may be short. +.le +.ls padchar = 0 +Single character used to pad blocks or records. +Padchar is only requested if pad_record or pad_block +is set. If padchar equals one of the digits 0 through nine, records and +blocks are padded with the face value of the character, otherwise the +ASCII value is used. +.le +.ls verbose = yes +Print messages about files, blocks copied etc. +.le +.ih +DESCRIPTION + +REBLOCK is a procedure to copy disk or tape resident files to +disk or tape. Multiple tape files or a single disk input file may be specified. +If multiple files are output to disk the output file names will be +generated by concatenating the tape file number onto the output file name. +The user may request magnetic tape output to begin at a specific file on +tape, e.g. mta1600[5] in which case file five will be overwritten if it +exists, or at BOT or EOT. If no file number is specified REBLOCK asks +whether the tape is new or old and begin writing at BOT or EOT as +appropriate. + +Before beginning the copy, the user may request reblock to skip +n (default 0) blocks (tape input) or logical records (disk input). +The user can also specify that +only n (default all) blocks (tape input) or records (disk input) +are to be copied. Before the copy the data may be optionally word-swapped +(default no) and/or byte-swapped (default no). If verbose is specified +(default yes) reblock prints the input and output file names, +the number of blocks read and written and the number of records read and +written. + +Reblock +uses the default buffer sizes supplied by mtio and file i/o to determine the +maximum number of bytes which can be read in a single read call. For tapes +this corresponds to the maximum number of bytes per block permitted by the +device. Mtio will not read more than one block per read call. Therefore the +actual number of bytes read will be less than or equal to the mtio buffer size. +For disk files the default buffer size set by IRAF is a multiple of the +disk block size. If the disk file is smaller than one block +or the last block is partially full, the number of bytes read +will be less than the default buffer size. All magtape and disk reads are +done with the file i/o read procedure and a call to fstati determines the number +of bytes actually read. + +If all the defaults are set, a binary copy is performed. +In tape to tape copies the block and record sizes are preserved, +but the density may +be changed by specifying the appropriate output file name e.g. mta800 or +mta1600. +Reblocking occurs in tape to disk transfers, if records, are trimmed, +padded or counted, or if blocks are padded. +If a disk to tape transfer is requested +the output block size will be the default file i/o buffer size. +The last block in a file may be short. If uniform sized blocks are +desired, pad_block must be set, in which case trailing partially filled +blocks will be padded with padchar. + +Logical records are distinguished from blocks (physical records). +The input and output record sizes default to +the size of the input and output blocks respectively. +Logical records may be shorter or longer than the block sizes. +.ih +EXAMPLES + +Copy a magnetic tape preserving the record sizes but changing +the density from 800 bpi to 1600 bpi. + +.nf + da> reblock mtb800, "mta1600[1]", "1-999" +.fi + +Reblock a magnetic tape changing the block size from 4000 bytes to 8000 +bytes and padding the last block. + +.nf + da> reblock mtb1600, "mta1600[1]", "1-999", outb=8000, padb+ +.fi + +Trim the records of a disk file. + +.nf + da> reblock input, output, inrec=80, outrec=72 +.fi + +Pad the records of a disk file with blanks. + +.nf + da> reblock input, output, inrec=81, outrec=82, padchar=" " +.fi + +.endhelp diff --git a/pkg/dataio/reblock/reblock_file.x b/pkg/dataio/reblock/reblock_file.x new file mode 100644 index 00000000..2801a1b1 --- /dev/null +++ b/pkg/dataio/reblock/reblock_file.x @@ -0,0 +1,416 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "reblock.h" + +# REB_REBLOCK_FILE -- Copy and optionally reblock files. + +procedure reb_reblock_file (in_fname, out_fname, outparam) + +char in_fname[ARB] # input file name +char out_fname[ARB] # output file name +int outparam[ARB] # output parameters + +char padchar +int in, out, sz_charsin, sz_charsout, mov_nbytes, rem_in, rem_out +int bytes_read, ip, op, i, first_byte, nchars, rec_count, ntrim +long offset +pointer inbuf, outbuf + +int mtopen(), reb_roundup(), read(), reb_skipover(), fstati(), open() +errchk open, mtopen, read, awriteb, awaitb, close, mfree, malloc, flush +errchk reb_write_block, reb_pad_block, reb_pad_record, reb_skipover +include "reblock.com" + +begin + # Open input and output files + in = mtopen (in_fname, READ_ONLY, 0) + out = NULL + + # Allocate space for input buffer. + sz_charsin = fstati (in, F_BUFSIZE) + call malloc (inbuf, sz_charsin, TY_CHAR) + outbuf = NULL + + # Skip over n input blocks (tape) or records (disk). + first_byte = 1 + if (intape == YES) { + for (i=1; i <= nskip; i = i + 1) { + nchars = read (in, Memc[inbuf], sz_charsin) + if (nchars == EOF) + call error (1,"Skipped past EOF on input.") + } + } else { + first_byte = reb_skipover (in, szb_inrecord, nskip) + if (first_byte == EOF) + call error (2, "Skipped past EOF on input.") + } + + # Initialize the input and output block and record counters + BLKS_RD(outparam) = 0 + BLKS_WRT(outparam) = 0 + RECS_RD(outparam) = 0 + RECS_WRT(outparam) = 0 + + # Initalize the record counter. + rec_count = 0 + + # Set of the offset in output file for asyncrhronous i/o. + offset = 1 + + # Loop over the input blocks. + repeat { + + # Read a block and update block counter. + nchars = read (in, Memc[inbuf], sz_charsin) + if (nchars == EOF) + break + bytes_read = nchars * SZB_CHAR + if (mod (fstati (in, F_SZBBLK), SZB_CHAR) != 0) + bytes_read = bytes_read - mod (fstati (in, F_SZBBLK), SZB_CHAR) + BLKS_RD(outparam) = BLKS_RD(outparam) + 1 + + # Align to first byte. + if (rec_count == 0 && first_byte > 1) { + bytes_read = bytes_read - first_byte + 1 + call bytmov (Memc[inbuf],first_byte, Memc[inbuf],1, bytes_read) + } + + # Open the output file. This has been moved from the beginning + # of the routine to avoid a magtape problem. + # driver problem. + if (BLKS_RD(outparam) == 1) { + if (outtape == NO) + out = open (out_fname, NEW_FILE, BINARY_FILE) + else + out = mtopen (out_fname, WRITE_ONLY, 0) + } + + # Binary copy. + if (reblock == NO) { + + RECS_RD(outparam) = BLKS_RD(outparam) + call reb_write_block (out, Memc[inbuf], bytes_read, offset, + byteswap, wordswap) + BLKS_WRT(outparam) = BLKS_WRT(outparam) + 1 + RECS_WRT(outparam) = BLKS_WRT(outparam) + + # Reblock. + } else { + + # Initialize reblocking parameters after first read. + if (BLKS_RD(outparam) == 1) { + + # Initialize block and record sizes + if (IS_INDEFI(szb_inrecord)) + szb_inrecord = sz_charsin * SZB_CHAR + if (IS_INDEFI(szb_outblock)) + szb_outblock = fstati (out, F_BUFSIZE) * SZB_CHAR + if (IS_INDEFI(szb_outrecord)) + szb_outrecord = szb_outblock + + # Set pad character. + if (pad_record == YES || pad_block == YES) { + padchar = char (padvalue) + call chrpak (padchar, 1, padchar, 1, 1) + } + + # Allocate space for the output buffer. + sz_charsout = reb_roundup (szb_outblock, SZB_CHAR) / + SZB_CHAR + call malloc (outbuf, sz_charsout, TY_CHAR) + + # Intialize the record remainder counters + rem_in = szb_inrecord + rem_out = szb_outrecord + + # Initialize input and output buffer pointers + ip = 1 + op = 1 + } + + # Loop over the input buffer. + repeat { + + # Calculate the number of bytes to be moved. + mov_nbytes = min (bytes_read - ip + 1, + rem_in, rem_out, szb_outblock - op + 1) + call bytmov (Memc[inbuf], ip, Memc[outbuf], op, mov_nbytes) + + # Update the remainders + rem_in = rem_in - mov_nbytes + if (rem_in == 0) + rem_in = szb_inrecord + rem_out = rem_out - mov_nbytes + if (rem_out == 0) + rem_out = szb_outrecord + + # Update the input and output buffer pointers. + ip = ip + mov_nbytes + op = op + mov_nbytes + + # Pad records. + if (pad_record == YES && rem_in == szb_inrecord) { + + # Do the padding. + if (mov_nbytes != 0) { + RECS_RD(outparam) = RECS_RD(outparam) + 1 + call reb_pad_record (Memc[outbuf], op, rem_out, + szb_outblock, szb_outrecord, padchar) + } else if (rem_out < szb_outrecord) + call reb_pad_record (Memc[outbuf], op, rem_out, + szb_outblock, szb_outrecord, padchar) + + # Increment the output record counter. + if (rem_out == szb_outrecord) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + else if (rem_out < szb_outrecord) + rem_in = 0 + } + + # If the output buffer is exhausted, output block of data. + if (op > szb_outblock) { + call reb_write_block (out, Memc[outbuf], szb_outblock, + offset, byteswap, wordswap) + BLKS_WRT(outparam) = BLKS_WRT(outparam) + 1 + op = 1 + } + + # Trim records. + if (trim_record == YES && rem_out == szb_outrecord) { + + # Do the trimming. + if (mov_nbytes != 0) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + ntrim = min (rem_in, bytes_read - ip + 1) + ip = ip + ntrim + rem_in = rem_in - ntrim + if (rem_in == 0) + rem_in = szb_inrecord + + # Increment the record counter. + if (rem_in == szb_inrecord) + RECS_RD(outparam) = RECS_RD(outparam) + 1 + else if (rem_in < szb_inrecord) + rem_out = 0 + } + + # Count the records. + if (pad_record == NO && trim_record == NO) { + if (szb_inrecord == sz_charsin * SZB_CHAR) + RECS_RD(outparam) = BLKS_RD(outparam) + else if (rem_in == szb_inrecord) + RECS_RD(outparam) = RECS_RD(outparam) + 1 + if (rem_out == szb_outrecord) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + } + + # Quit if ncopy records has been reached. + if (intape == NO && RECS_RD(outparam) == ncopy) + break + + } until (ip > bytes_read) + + # Reset the input buffer pointer + ip = 1 + } + + # Update the record counter. + if (intape == YES) + rec_count = BLKS_RD(outparam) + else + rec_count = RECS_RD(outparam) + + } until (rec_count >= ncopy) + + # Output remainder of data + if (reblock == YES) { + + # Pad last record if short. + if (pad_record == YES) { + if (rem_in < szb_inrecord) + RECS_RD(outparam) = RECS_RD(outparam) + 1 + if (rem_out < szb_outrecord) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + while (rem_out < szb_outrecord) { + call reb_pad_record (Memc[outbuf], op, rem_out, + szb_outblock, szb_outrecord, padchar) + if (op > szb_outblock) { + call reb_write_block (out, Memc[outbuf], szb_outblock, + offset, byteswap, wordswap) + BLKS_WRT(outparam) = BLKS_WRT(outparam) + 1 + op = 1 + } + } + } + + # Pad last block if short. + if (pad_block == YES && op > 1) + call reb_pad_block (Memc[outbuf], op, rem_out, outparam, + szb_outblock, szb_outrecord, padchar) + + # Write last block + if (op > 1) { + call reb_write_block (out, Memc[outbuf], op - 1, offset, + byteswap, wordswap) + op = 1 + BLKS_WRT(outparam) = BLKS_WRT(outparam) + 1 + if (pad_record == YES && rem_out < szb_outrecord) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + else if (rem_out < szb_outrecord) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + } + + } + + call mfree (inbuf, TY_CHAR) + if (outbuf != NULL) + call mfree (outbuf, TY_CHAR) + call close (in) + if (out != NULL) + call close (out) +end + + +# REB_PAD_RECORD -- Procedure for padding records. + +procedure reb_pad_record (buffer, op, rem_out, szb_outblock, szb_outrecord, + padchar) + +char buffer[ARB], padchar +int szb_outblock, szb_outrecord, op, rem_out +int i, junk + +begin + junk = rem_out + for (i = 1; i <= junk && op <= szb_outblock; i = i + 1) { + call bytmov (padchar, 1, buffer, op, 1) + op = op + 1 + rem_out = rem_out - 1 + } + + if (rem_out == 0) + rem_out = szb_outrecord +end + + +# REB_PAD_BLOCK -- Procedure to pad the last block so that all output blocks +# will have the same size. + +procedure reb_pad_block (buffer, op, rem_out, outparam, szb_outblock, + szb_outrecord, padchar) + +char buffer[ARB] # data to be padded +int op # pointer to first element for padding +int rem_out # number of remaining bytes to be padded in a record +int outparam[ARB] # output parameters, number of records, blocks written +int szb_outblock # size in bytes of output block +int szb_outrecord # size in bytes of an output record +char padchar # character used for padding + +int i, junk + +begin + junk = szb_outblock - op + 1 + for (i = 1; i <= junk; i = i + 1) { + call bytmov (padchar, 1, buffer, op, 1) + op = op + 1 + rem_out = rem_out - 1 + if (rem_out == 0) { + rem_out = szb_outrecord + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + } + } +end + + +# REB_WRITE_BLOCK -- Procedure to write blocks using the asynchronous read +# and write functions in file i/o. Writing must occur on block boundaries. + +procedure reb_write_block (fd, buffer, nbytes, offset, byteswap, wordswap) + +int fd # output file descriptor +char buffer[ARB] # data to be output +int nbytes # number of bytes of data +long offset # offset in chars in output file for writing +int byteswap # swap every other byte before output +int wordswap # swap every other word before output + +int nbread +int awaitb() +errchk awriteb, awaitb + +begin + if (byteswap == YES) + call bswap2 (buffer, 1, buffer, 1, nbytes) + if (wordswap == YES) + call bswap4 (buffer, 1, buffer, 1, nbytes) + call awriteb (fd, buffer, nbytes, offset) + nbread = awaitb (fd) + if (nbread == ERR) + call error (3, "Error writing block data") + else + offset = offset + nbread +end + + +# REB_SKIPOVER -- Procedure to find the first byte containing data given the +# input block size and the number of input blocks to be skipped. + +int procedure reb_skipover (fd, szb_inblock, nskip) + +int fd # file descriptor +int szb_inblock # size of an input block +int nskip # number of blocks to skip + +int first_byte +long szb_skip, szb_physkip, skip_diff, sz_charoff, loff +long fstatl() +int reb_roundup() +errchk fstatl, seek + +begin + szb_skip = long (szb_inblock) * long (nskip) + szb_physkip = reb_roundup (szb_skip, SZB_CHAR) + skip_diff = szb_physkip - szb_skip + + if (skip_diff == 0) { + sz_charoff = (szb_physkip / SZB_CHAR) + 1 + first_byte = 1 + } else { + sz_charoff = (szb_physkip / SZB_CHAR) - 1 + first_byte = int (szb_skip - (SZB_CHAR * sz_charoff) + 1) + } + + loff = long (sz_charoff) + + if (loff > fstatl (fd, F_FILESIZE)) { + call seek (fd, EOF) + return (EOF) + } else { + call seek (fd, loff) + return (first_byte) + } +end + + +# REB_ROUNDUP -- Procedure to round a number to the next highest number +# divisible by base. + +int procedure reb_roundup (number, base) + +int number # number to be rounded upwards +int base # base for rounding + +int value + +begin + if (mod(number, base) == 0) + return (number) + else { + value = (number/base + 1) * base + return (value) + } +end diff --git a/pkg/dataio/reblock/structure.hlp b/pkg/dataio/reblock/structure.hlp new file mode 100644 index 00000000..1a7c5221 --- /dev/null +++ b/pkg/dataio/reblock/structure.hlp @@ -0,0 +1,50 @@ +.help gcopy "Program Structure" +.sh +Program Structure +.nf +t_bincopy() +# Returns when file list is finished or EOT reached. + + read_file (in_fname, out_fname, outparam) + Returns when an EOF is encountered on read. + + skipover (fd, szb_outblock, nskip) + # Returns the offset of the first data byte in the first char + # to contain data of interest or EOF + + record_pad (szb_outblock, szb_outrecord, padchar, buffer, op, rem_out) + + block_pad (szb_outblock, szb_outrecord, padchar, buffer, op, rem_out, + outparam) +.fi +.sh +BINCOPY Structure Summary +.ls t_bincopy +The main program gets the input and output filenames, creates a list of +files to be processed and gets the program parameters. +For each file in the input list READFILE is called, +and the input and output file names, blocks read and written and records read +and written are printed. +The program terminates when the input file list is exhausted or EOT is reached. +.ls read_file +READ_FILE opens the input and output devices, allocates space for the input +and output buffers and copies the data optionally skipping data +and byteswapping and/or wordswapping the data. +The routine terminates when an EOF is encountered on a read. +READ_FILE calls SKIPOVER to find the first data byte of interest and +RECORD_PAD and BLOCK_PAD to pad records and blocks respectively. +.ls skipover +SKIPOVER seeks to the first char containing data of interest and calculates +the offset in that char of the first byte of interest. Returns the offset +or EOF if the requested position is past EOF. +.le +.ls record_pad +Record_pad pads input records of szb_inrecord bytes long to output records +szb_outrecord long. +.le +.ls block_pad +Pads short blocks to size szb_outblock. +.le +.le +.le +.endhelp diff --git a/pkg/dataio/reblock/t_reblock.x b/pkg/dataio/reblock/t_reblock.x new file mode 100644 index 00000000..09c86a9a --- /dev/null +++ b/pkg/dataio/reblock/t_reblock.x @@ -0,0 +1,214 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "reblock.h" + +define MAX_RANGES 100 +define SZ_PADCHAR 10 + +# T_REBLOCK -- Procedure to copy binary files optionally changing the blocking +# factor. Further documentation in reblock.hlp. + +procedure t_reblock () + +char infiles[SZ_FNAME] # list of input files +char file_list[SZ_LINE] # list of tape file numbers +char outfiles[SZ_FNAME] # list of output files +char padchar[SZ_PADCHAR] # character for padding blocks and records +bool verbose # print messages ? + +char in_fname[SZ_FNAME], out_fname[SZ_FNAME], cval +int inlist, outlist, len_inlist, len_outlist, file_number, file_cnt +int range[2 * MAX_RANGES + 1] +int outparam[LEN_OUTPARAM], offset, ip + +bool clgetb() +int fstati(), mtfile(), mtneedfileno(), fntopnb(), fntlenb(), fntgfnb() +int decode_ranges(), btoi(), clgeti(), get_next_number(), cctoc() +include "reblock.com" + +begin + # Flush on a newline if the output is not redirected. + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Get the input and output file(s). + call clgstr ("infiles", infiles, SZ_FNAME) + call clgstr ("outfiles", outfiles, SZ_FNAME) + + # Get the input file names. + if (mtfile (infiles) == YES) { + inlist = NULL + intape = YES + if (mtneedfileno (infiles) == YES) + call clgstr ("file_list", file_list, SZ_LINE) + else + call strcpy ("1", file_list, SZ_LINE) + } else { + inlist = fntopnb (infiles, NO) + len_inlist = fntlenb (inlist) + intape = NO + if (len_inlist > 0) { + call sprintf (file_list, SZ_LINE, "1-%d") + call pargi (len_inlist) + } else + call strcpy ("0", file_list, SZ_LINE) + } + + # Decode the tape file number list. + if (decode_ranges (file_list, range, MAX_RANGES, len_inlist) == ERR) + call error (0, "Illegal file number list.") + offset = clgeti ("offset") + + # Get the output file names. + if (mtfile (outfiles) == YES) { + outlist = NULL + len_outlist = len_inlist + outtape = YES + if (mtneedfileno (outfiles) == YES) { + if (! clgetb ("newtape")) + call mtfname (outfiles, EOT, out_fname, SZ_FNAME) + else + call mtfname (outfiles, 1, out_fname, SZ_FNAME) + } else + call strcpy (outfiles, out_fname, SZ_FNAME) + } else { + outlist = fntopnb (outfiles, NO) + len_outlist = fntlenb (outlist) + outtape = NO + } + if ((len_inlist > 1) && (len_outlist != 1) && + (len_outlist != len_inlist)) + call error (0, + "The number of input and output files is not equal") + + # Get the block and record sizes. + szb_outblock = clgeti ("outblock") + if (outtape == NO) + szb_outblock = INDEFI + szb_inrecord = clgeti ("inrecord") + szb_outrecord = clgeti ("outrecord") + if (IS_INDEFI(szb_inrecord) && !IS_INDEFI(szb_outrecord)) + szb_inrecord = szb_outrecord + if (IS_INDEFI(szb_outrecord) && !IS_INDEFI(szb_inrecord)) + szb_outrecord = szb_inrecord + + # Get the pad and trim parameters. + pad_block = btoi (clgetb ("pad_block")) + if (szb_inrecord < szb_outrecord) + pad_record = YES + else + pad_record = NO + if (szb_inrecord > szb_outrecord) + trim_record = YES + else + trim_record = NO + if (pad_block == YES || pad_record == YES) { + call clgstr ("padchar", padchar, SZ_PADCHAR) + ip = 1 + if (cctoc (padchar, ip, cval) <= 0) + cval = ' ' + if (IS_DIGIT (cval)) + padvalue = TO_INTEG (cval) + else + padvalue = cval + } + + # Tape to disk always requires reblocking. + if (intape == YES && outtape == NO) + reblock = YES + else if (pad_record == YES || pad_block == YES || trim_record == YES) + reblock = YES + else if (!IS_INDEFI(szb_outblock) || !IS_INDEFI(szb_inrecord) || + !IS_INDEFI(szb_outrecord)) + reblock = YES + else + reblock = NO + + # Get remaining parameters. + nskip = max (0, clgeti ("skipn")) + ncopy = clgeti ("copyn") + if (IS_INDEFI(ncopy)) + ncopy = MAX_INT + byteswap = btoi (clgetb ("byteswap")) + wordswap = btoi (clgetb ("wordswap")) + verbose = clgetb ("verbose") + + # Loop through the files + file_cnt = 1 + file_number = 0 + while (get_next_number (range, file_number) != EOF) { + + # Construct the input file name. + if (intape == YES) { + if (mtneedfileno (infiles) == YES) + call mtfname (infiles, file_number, in_fname, SZ_FNAME) + else + call strcpy (infiles, in_fname, SZ_FNAME) + } else if (fntgfnb (inlist, in_fname, SZ_FNAME) != EOF) + ; + + # Construct the output file name. + if (outtape == NO) { + if (len_inlist > 1 && len_outlist == 1) { + call sprintf (out_fname[1], SZ_FNAME, "%s%03d") + call pargstr (outfiles) + if (intape == YES) + call pargi (file_number + offset) + else + call pargi (file_cnt) + } else if (fntgfnb (outlist, out_fname, SZ_FNAME) != EOF) + ; + } else if (file_cnt == 2) + call mtfname (out_fname, EOT, out_fname, SZ_FNAME) + + iferr { + + if (verbose) { + call printf ("File: %s -> %s: ") + call pargstr (in_fname) + call pargstr (out_fname) + } + + call reb_reblock_file (in_fname, out_fname, outparam) + + if (verbose) { + if (intape == YES) + call printf ("[skip %d blks] ") + else + call printf ("[skip %d recs] ") + call pargi (nskip) + call printf ("blks r/w %d/%d ") + call pargi (BLKS_RD(outparam)) + call pargi (BLKS_WRT(outparam)) + if (reblock == YES) { + call printf ("recs r/w %d/%d\n") + call pargi (RECS_RD(outparam)) + call pargi (RECS_WRT(outparam)) + } else + call printf ("\n") + } + + } then { + call flush (STDOUT) + call eprintf ("Cannot read file %s\n") + call pargstr (in_fname) + } else if (BLKS_RD(outparam) == 0) { + if (verbose) { + call printf ("Empty file: %s\n") + call pargstr (in_fname) + } + break + } else { + file_cnt = file_cnt + 1 + } + } + + if (inlist != NULL) + call fntclsb (inlist) + if (outlist != NULL) + call fntclsb (outlist) +end diff --git a/pkg/dataio/rfits.par b/pkg/dataio/rfits.par new file mode 100644 index 00000000..6ea66586 --- /dev/null +++ b/pkg/dataio/rfits.par @@ -0,0 +1,12 @@ +fits_file,f,a,"mta",,,"FITS data source" +file_list,s,a,"",,,"File/extensions list" +iraf_file,f,a,"",,,"IRAF filename" +make_image,b,h,yes,,,"Create an IRAF image?" +long_header,b,h,no,,,"Print FITS header cards?" +short_header,b,h,yes,,,"Print short header?" +datatype,s,h,"",,,"IRAF data type" +blank,r,h,0.,,,"Blank value" +scale,b,h,yes,,,"Scale the data?" +oldirafname,b,h,no,,,"Use old IRAF name in place of iraf_file?" +offset,i,h,0,,,"Tape file offset" +mode,s,h,"ql",,, diff --git a/pkg/dataio/rtextimage.par b/pkg/dataio/rtextimage.par new file mode 100644 index 00000000..86614e90 --- /dev/null +++ b/pkg/dataio/rtextimage.par @@ -0,0 +1,9 @@ +# Parameter file for t_rtextimage, text file to IRAF image converter + +input,f,a,,,,Input text file +output,f,a,,,,Output image file +otype,s,h,"",,,Pixel type on output +header,b,h,yes,,,Read FITS header preceding pixels? +pixels,b,h,yes,,,Read pixels? +nskip,i,h,0,,,Number of lines to skip +dim,s,h,,,,Image dimension string diff --git a/pkg/dataio/t2d.par b/pkg/dataio/t2d.par new file mode 100644 index 00000000..a50cbbd5 --- /dev/null +++ b/pkg/dataio/t2d.par @@ -0,0 +1,5 @@ +input,s,a,,,,Input file descriptor +ofroot,s,a,,,,Output file root name +files,s,a,,,,List of files +verbose,b,h,yes,,,Print out progress reports +errignore,b,h,yes,,,Assume an error record is zero bytes long diff --git a/pkg/dataio/t2d/mkpkg b/pkg/dataio/t2d/mkpkg new file mode 100644 index 00000000..32b680dd --- /dev/null +++ b/pkg/dataio/t2d/mkpkg @@ -0,0 +1,10 @@ +# T2d contributions to Dataio Library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_t2d.x + ; diff --git a/pkg/dataio/t2d/t_t2d.x b/pkg/dataio/t2d/t_t2d.x new file mode 100644 index 00000000..f21fe4da --- /dev/null +++ b/pkg/dataio/t2d/t_t2d.x @@ -0,0 +1,280 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define OBUF_PAD 35536 +define SZ_OBUF 100000 +define SWAP {temp=$1;$1=$2;$2=temp} +define MAX_RANGES 200 + +# T2D -- This is an asynchronous tape to disk copy routine. +# T2d sets up a large output buffer (many blocks long) and reads from +# the input device directly into this output buffer, keeping track of where in +# the output buffer it is. When it reaches a predetermined point in the output +# buffer, it writes an integral number of blocks to the output device, moves +# the leftover input data to the beginning of the alternate buffer and +# continues reading. (until EOF, then it writes out whatever is left). +# The user specifies which files on tape he or she wants and a root name +# for the output file names. + +procedure t_t2d() + +char input[SZ_FNAME] +char files[SZ_LINE] +char ofroot[SZ_FNAME] # Root file name, output files. + +char tapename[SZ_FNAME] +char dfilename[SZ_FNAME] # Disk file name. +int filerange[2 * MAX_RANGES + 1] +int nfiles, filenumber, numrecords +bool verbose +bool errignore + +int mtfile(), strlen(), decode_ranges(), mtneedfileno() +int get_next_number(), tape2disk() +bool clgetb() + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + + # Get input file(s). + call clgstr ("input", input, SZ_FNAME) + if (mtfile(input) == NO || mtneedfileno(input) == NO) + call strcpy ("1", files, SZ_LINE) + else + call clgstr ("files", files, SZ_LINE) + + if (decode_ranges (files, filerange, MAX_RANGES, nfiles) == ERR) + call error (0, "Illegal file number list.") + + # Get root output filename, the verbose flag, and the error-ignore flag. + call clgstr ("ofroot", ofroot, SZ_FNAME) + verbose = clgetb ("verbose") + errignore = clgetb ("errignore") + filenumber = 0 + + if (mtfile(input) == YES && mtneedfileno(input) == YES) { + # Loop over files + while (get_next_number (filerange, filenumber) != EOF) { + + # Assemble the appropriate tape file name. + call mtfname (input, filenumber, tapename, SZ_FNAME) + + # Assemble the appropriate disk file name. + call strcpy (ofroot, dfilename, SZ_FNAME) + call sprintf (dfilename[strlen(ofroot) + 1], SZ_FNAME, "%03d") + call pargi (filenumber) + + # Print out the tape file we are trying to read. + if (verbose) { + call printf ("%s ") + call pargstr (tapename) + call flush (STDOUT) + } + + + # Do the tape to disk transfer. + iferr { + numrecords = tape2disk (tapename, dfilename, errignore) + } then { + call eprintf ("Error reading file: %s\n") + call pargstr (tapename) + call erract (EA_WARN) + next + } else if (numrecords == 0) { + call deletefg (dfilename, YES, YES) + if (verbose) + call printf ("Tape at EOT\n") + break + } else if (verbose){ + call printf (" wrote `%s'\n") + call pargstr(dfilename) + } + + } # End while. + + } else { + + # Print out the tape file we are trying to read. + if (verbose) { + call printf ("%s ") + call pargstr(input) + call flush (STDOUT) + } + + # Do the tape to disk transfer. + iferr { + numrecords = tape2disk (input, ofroot, errignore) + } then { + call eprintf ("Error reading file: %s\n") + call pargstr (input) + call erract (EA_WARN) + } else if (numrecords == 0) { + call deletefg (input, YES, YES) + if (verbose) + call printf ("Tape at EOT\n") + } else if (verbose){ + call printf (" wrote `%s'\n") + call pargstr(ofroot) + } + } +end + + +# TAPE2DISK -- This is the actual tape to disk copy routine. + +int procedure tape2disk (infile, outfile, errignore) + +char infile[SZ_FNAME] +char outfile[SZ_FNAME] +bool errignore + +bool inblock +int blksize, mxbufszo, numblks, cutoff, obufsize, temp, numrecords +int inblksize, innumblks, toread, mxbufszi +long ooffset +int nchars, stat, in, out, lastnchars +pointer op, otop, bufa, bufb + +int fstati(), mtopen(), open(), await() + +begin + # Open the input and output files. + in = mtopen (infile, READ_ONLY, 0) + out = open (outfile, NEW_FILE, BINARY_FILE) + + # Find out how big the blocks are on the output device. Calculate + # an output buffer size which is an integral number of blocks long + # and is long enough to permit many input reads per output write. + # Here, I use the maximum output buffer size. + + blksize = fstati (out, F_BLKSIZE) # Outputfile block size + mxbufszo = fstati (out, F_MAXBUFSIZE) # Maximum output buffer size + mxbufszi = fstati (in, F_MAXBUFSIZE) # Maximum in buffer size + if (mxbufszo <= 0) # if no max, set a max + mxbufszo = SZ_OBUF + if (mxbufszi <= 0) # if no max, set a max + mxbufszi = OBUF_PAD + numblks = mxbufszo / blksize # No. blocks in 'out' buffer + + # Find out if the input device is blocked and if it is, the block + # size. + inblksize = fstati (in, F_BLKSIZE) # Inputfile block size + inblock = true + if (inblksize == 0) + inblock = false + + # Put an extra OBUF_PAD chars in the output buffer to allow for + # overruns on the last input read before we do an output write. + + cutoff = numblks * blksize + obufsize = cutoff + OBUF_PAD + + call malloc (bufa, obufsize, TY_CHAR) # Allocate output buffer. + call malloc (bufb, obufsize, TY_CHAR) # Other output buffer + op = bufa # Movable pointer inside buffer + otop = bufa + cutoff # Point to full position (top) + + ooffset = 1 # Output offset. + nchars = 0 # Number of chars. + numrecords = 0 # Number of records read. + lastnchars = 0 + + # Main Loop. + repeat { + # A series of reads of the input file are required to fill the + # output buffer. + + if (inblock) { + innumblks = (cutoff - (op - bufa)) / inblksize + toread = (innumblks+1) * inblksize + + call aread (in, Memc[op], toread, 1) + nchars = await (in) + if (nchars <= 0) { + if (nchars == ERR) { + # report read error + call eprintf ("error on read\n") + call flush (STDERR) + + # If errignore, do not move pointer, else, + # assume data. + if (!errignore) + nchars = toread + } + # If we found the EOF + if (nchars == 0) { + cutoff = op - bufa + } + } else if (nchars < toread) { + numrecords = numrecords + 1 + cutoff = op - bufa + nchars + nchars = 0 + } else { + numrecords = numrecords + 1 + op = op + nchars + } + + } else { + + repeat { + call aread (in, Memc[op], mxbufszi, 1) + nchars = await (in) + + if (nchars <= 0) { + if (nchars == ERR) { + # report read error + call eprintf ("error on read\n") + call flush (STDERR) + + # If errignore, do not move pointer, else, + # assume data. + if (!errignore) + nchars = lastnchars + } + # If we found the EOF + if (nchars == 0) { + cutoff = op - bufa + break + } + } + + if (nchars > 0) { + numrecords = numrecords + 1 + lastnchars = nchars + op = op + nchars + } + + } until (op >= otop) + } # end of 'if (inblock)' + + # Wait for last write to finish and initiate next write. + stat = await (out) + if (stat == ERR) + call eprintf ("error on write\n") + call awrite (out, Memc[bufa], cutoff, ooffset) + ooffset = ooffset + cutoff # Update the output offset. + + # Copy leftover buffer elements into the bottom of other buffer. + if ((op - otop) > 0) + call amovc (Memc[otop], Memc[bufb], op - otop) + op = bufb + (op - otop) + + # Swap buffers + SWAP (bufa, bufb) + otop = bufa + cutoff + } until (nchars == 0) # all done + + stat = await (out) # wait for final write to finish. + if (stat == ERR) + call eprintf ("error on write\n") + + call close (in) + call close (out) + call mfree (bufa, TY_CHAR) + call mfree (bufb, TY_CHAR) + + return (numrecords) +end diff --git a/pkg/dataio/txtbin.par b/pkg/dataio/txtbin.par new file mode 100644 index 00000000..09e9bf97 --- /dev/null +++ b/pkg/dataio/txtbin.par @@ -0,0 +1,4 @@ +mode,s,h,"ql",,, +text_file,s,a,,,,Input file name(s) +binary_file,s,a,,,,Output file name(s) +verbose,b,h,yes,,,Print messages? diff --git a/pkg/dataio/wcardimage.par b/pkg/dataio/wcardimage.par new file mode 100644 index 00000000..610a867d --- /dev/null +++ b/pkg/dataio/wcardimage.par @@ -0,0 +1,11 @@ +mode,s,h,"ql",,, +textfile,s,a,,,,"Text file(s)" +cardfile,s,a,,,,"Card image file(s)" +new_tape,b,a,,,,"Blank tape?" +contn_string,s,h,>>,,,"Marker for oversize lines" +verbose,b,h,yes,,,"Print messages of actions performed?" +detab,b,h,yes,,,"Detab string and replace with blanks?" +card_length,i,h,80,,,"Columns per card" +cards_per_blk,i,h,50,,,"Card images per block" +ebcdic,b,h,no,,,"Convert from ASCII to EBCDIC?" +ibm,b,h,no,,,"Convert from ASCII to IBM(EBCDIC)?" diff --git a/pkg/dataio/wfits.par b/pkg/dataio/wfits.par new file mode 100644 index 00000000..eb48586b --- /dev/null +++ b/pkg/dataio/wfits.par @@ -0,0 +1,18 @@ +# WFITS parameters + +iraf_files,s,a,,,,IRAF images +fits_files,f,a,,,,FITS filename(s) +newtape,b,a,,,,Blank tape? +fextn,s,h,"fits",,,Extension to append to output disk FITS filename(s) +extensions,b,h,no,,,Write all images to a single FITS file ? +global_hdr,b,h,yes,,,Prepend a global header to the FITS extensions file ? +make_image,b,h,yes,,,Create a FITS image file? +long_header,b,h,no,,,Print FITS header cards? +short_header,b,h,yes,,,Print short header? +bitpix,i,h,0,,,FITS bits per pixel +blocking_factor,i,h,0,0,10,FITS tape blocking factor +scale,b,h,yes,,,Scale data? +autoscale,b,h,yes,,,Auto_scaling? +bscale,r,a,1.0,,,FITS bscale +bzero,r,a,0.0,,,FITS bzero +mode,s,h,ql,,, diff --git a/pkg/dataio/wtextimage.par b/pkg/dataio/wtextimage.par new file mode 100644 index 00000000..276a9728 --- /dev/null +++ b/pkg/dataio/wtextimage.par @@ -0,0 +1,8 @@ +# Parameter file for t_wtextimage, IRAF image to text file converter + +input,f,a,,,,Input image file +output,f,a,,,,Output text file +header,b,h,yes,,,Print header information? +pixels,b,h,yes,,,Print pixel values? +format,s,h,"",,,Pixel format +maxlinelen,i,h,80,1,322,Maximum line length output diff --git a/pkg/dataio/x_dataio.x b/pkg/dataio/x_dataio.x new file mode 100644 index 00000000..598c1e6e --- /dev/null +++ b/pkg/dataio/x_dataio.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Dataio package. + +task rcardimage = t_rcardimage, + wcardimage = t_wcardimage, + mtexamine = t_mtexamine, + txtbin = t_txtbin, + bintxt = t_bintxt, + rtextimage = t_rtextimage, + wtextimage = t_wtextimage, + reblock = t_reblock, + rfits = t_rfits, + wfits = t_wfits, + t2d = t_t2d, + import = t_import, + export = t_export diff --git a/pkg/dbms/dbms.cl b/pkg/dbms/dbms.cl new file mode 100644 index 00000000..cf0d2db0 --- /dev/null +++ b/pkg/dbms/dbms.cl @@ -0,0 +1,4 @@ +# Dummy package script task assigned to packages which have not yet been +# released. + += "not yet available" diff --git a/pkg/dbms/dbms.par b/pkg/dbms/dbms.par new file mode 100644 index 00000000..8dd742c9 --- /dev/null +++ b/pkg/dbms/dbms.par @@ -0,0 +1,3 @@ +# Dummy package parameter file. + +version,s,h,"release_date_of_package" diff --git a/pkg/ecl/Notes.ecl b/pkg/ecl/Notes.ecl new file mode 100644 index 00000000..e9ed3cea --- /dev/null +++ b/pkg/ecl/Notes.ecl @@ -0,0 +1,1098 @@ + + ECL: Enhanced CL Release Notes and User's Guide + ================================================ + + Michael Fitzpatrick + NOAO/IRAF Group + 12/12/04 + + Revised: 5/28/05 + + +******************************************************************************** +Release History: + 02/10/05 ** Alpha Release for testing + 05/06/05 ** 2nd Alpha Release for testing + 06/07/05 ** 1st Beta Release for testing + + +******************************************************************************** + +Table of Contents +----------------- + + Introduction + + Installation and Use + To Install the CL + Determine CL Version Type + + Error Handling + Introduction and Cautions + Example Descriptions + Reporting Errors + Traceback + Trapping Errors + The 'iferr' Syntax + The 'erract' Environment Variable + Error Handling: Then and Now + New CL parameters + What Errors Are NOT Trapped + + Command-line History and BackSpace Revisions + Input Command Summary + + New Builtin Functions and Variables + Error Functions + String Functions + Trig Functions + Utility Functions + Bitwise Operations + + Defined Constants + + Post-Release Notes + + +******************************************************************************** + +============ +Introduction +============ + + The primary goals of the ECL project were to + + o add an error-handling capability to the existing IRAF CL, + o include other functionality which could improve the + scripting environment (e.g. pre-defined language constants + such as 'PI') and add any other features we found lacking + (e.g. missing trig functions and string utilities), and + o add commonly requested features. + +Where possible, small enhancements such as a new utility builtin function +will be implemented in the "old" CL as well, however as scripts begin to +use the more advanced features scripts will naturally become less backward +compatible. Future work will build on the version presented here with +the hope that users will migrate to the new system over a short time. + + This is a work in progress. Users are encouraged to experiment with +features, request future enhancements, and to please report any errors or +problems to + iraf@noao.edu + +New releases will be announced on the IRAF website (http://iraf.noao.edu) +following the addition of any new features or when critical bugs have been +fixed. + + + +==================== +Installation and Use +==================== + + The ECL is being distributed in a self-extracting script file +rather than the traditional IRAF external package since it is meant to +overlay an existing IRAF system until the time when it becomes part of +the core distribution. Since the script creates a new command link in +the unix system "local bin directory" and adds files to the IRAF source +tree, it MUST be run as the root user (the script will terminate or ask +if you wish to proceed with a no-op installation otherwise). + +The installation script does the following to your system: + + 1) Replaces the existing hlib$cl.csh script with a modified + version after creating a hlib$cl.csh.ORIG backup file + + 2) Creates an "ecl" command link in the same directory as the + current "cl" IRAF command link. Both links point to the same + hlib$cl.csh script which checks for how it was called an + invokes the proper binary. + + 3) Moves the "ecl.e" binary to the proper iraf$bin. directory, + changing the ownership to the 'iraf' user and setting the execute + permissions on the file. + + 4) Creates a iraf$pkg/ecl directory and moves all ECL sources there. + +The install script may be run from any directory on the system, it is +unpacked in /tmp and cleans up temp files when complete. A "personal +installation" option is not implemented at this time but could be considered +later for users who don't have write permission on their IRAF tree. Please +contact iraf@noao.edu for instructions on how to manually setup such a +system for personal use. + + +To Install the ECL +------------------ + +Step 1) Download the distribution file appropriate for your system. For + example, + + % ftp iraf.noao.edu (140.252.1.1) + login: anonymous + password: [your email address] + ftp> cd pub + ftp> binary + ftp> get ecl_install_redhat.csh + ftp> quit + +Step 2) Execute the script AS ROOT: + + % su # become the root user + # ./ecl_install_redhat.csh + + The script will prompt you for the local bin directory or any + iraf paths needed, simply accept the default values determined for + your system or override them with others. + + Once executed, the ECL source and binaries will be installed in + the system as described above. The file you are reading right + now is available as iraf$pkg/ecl/Notes.ecl and will be updated + with post-release notes at the end of the file with each new + release. + +Step 3) Start the ECL from your normal IRAF login directory as either + + % ecl + or + % cl -ecl + + The second form of the command is needed on systems which mount + IRAF from another machine since the CL command links are created + at IRAF install time. One reason for replacing the hlib$cl.csh + script is to allow for the "-ecl" argument to override the binary + to be used on systems where only the 'cl' command is available and + so that the installation isn't required on all machines mounting + a common IRAF. + + The default ECL prompt is now "ecl>" in the new version as a visual + clue that the new system is being used. Additionally, package prompts + default to using the complete package name rather than the familiar + 2-character prefix as another clue. This behavior can be changed + by adding the string "nolongprompt" to the CL 'ehinit' parameter, + e.g. + + cl> cl.ehinit = cl.ehinit // " nolongprompt" + + +Except as described below, use of the ECL should be identical to the +traditional CL for most users. + + +Determining CL Version +---------------------- + + As users begin to make regular use of features found only in the +ECL, the first error to be checked is that the script is running using the +proper version of the CL. This needs to be done using features found in +both the ECL and traditional CL languages. The simplest test, for either +package loading scripts or within tasks, is something like + + if (defpar ("$errno")) { + print ("You are using the ECL") + } else { + print ("You are using the old CL") + } + + + + +============== +Error Handling +============== + +Introduction and Cautions +========================= + + The error-handling enhancements are composed of two elements: + + o the reporting of errors within scripts, and + o the ability to trap and recover those errors. + +The first case addresses the long-standing problem in which an error message +returned by a script gives a line number that has no basis in reality, and +which gives no useful information about the underlying task that created it. +In the second case, one often wants scripts to be able to trap errors from +compiled tasks so that some sort of cleanup can be done in order to allow +the script to continue, or so that an error status code can be examined +and some specific action taken (which may simply be to ignore the error). + + In the ECL, messages are now printed with the correct line number and +with a detailed traceback to the user's command-line showing more precisely +what was called at the time of the error. New language constructs are +available which allow scripts to conditionally check for errors from +tasks they call and branch to code to deal with those errors. Finally, +new ECL environment variables and builtin functions allow for limited +error-handling control over scripts already in the system which have not +been retrofitted to specifically trap errors. Details of each of these +capabilities and examples of how they may be used by developers and users +are given below. It is also worth discussing the types of errors which +can occur in a script task before getting into details about how they +might be handled by the user or script programmer. + +Error conditions in the CL break down into roughly the following types: + + Error Type Examples + ---------- -------- + + Compiled Task Errors 1) A call to a compiled task in the system + dies unexpectedly with an exception (e.g. + FPE, segmentation violation, etc) + 2) A task aborts due to an error condition the + task has trapped and cannot recover (e.g. + invalid parameters, out of memory, etc). + + CL Internal Errors 1) Script code performs an illegal operation + causing an exception (e.g. "i = j / k" + where 'k' is zero. + 2) Script code triggers a runtime error within + the CL itself (e.g. "log (string_value)") + + CL Error Assertions 1) Script programmer forces the task to exit + with a call to the CL error() builtin. + 2) Script programmer simply prints and error + message indicating a problem and returns + without further processing. + +All of these errors can be detected at some level, however not all of +them can be handled in a way which allows a calling script to recover +and continue executing, nor would it always make sense to do so. +Errors such as a floating-point-exception (FPE) may be data-dependent, +a segmentation violation may indicate a coding error in a compiled task +or a platform-specific bug, or an error in another script task may be +beyond the control of the scripter to fix. Error assertions by a script +programmer are not meant to be recoverable, and in the second example +an arbitrary problem message cannot be trapped by the system. + + An error-handling capability in the ECL (or any language) is not a +panacea for all error conditions one might encounter, the best a script +programmer can hope to do is to trap an error and take some reasonable +action at the time. The ECL offers a way for a script to print a more +meaningful error message, or at least abort gracefully after cleaning +itself up. However, depending on the type of error, *your* script may +still never run to completion until somebody else fixes *their* code. + + Lastly, it is also important to note that trapping an error means the +script finds itself in an unnatural state. Proper recovery requires +that the script programmer understand the error condition as well as +the state of the script at that point of execution. The error-handling +code must restore the script to a state where it can continue running +(if possible) and avoid potential side-effects caused by e.g. forgetting +to clean up intermediate files or reset counter variables. New language +features mean new types of bugs can be introduced into a script, even if +the irony is that these new features are meant to trap bugs! + + +Example Descriptions +-------------------- + + In the examples to follow we will make use of an ERRTEST package +distributed with the ECL source and containing the following tasks used +in the examples to follow: + + nested -- Test various error conditions from layered scripts + nest0 -- Dummy layer for nested testing + errtype -- Low-level script to test compiled and CL error conditions + + fpe -- Compiled task producing an arithmetic exception + segvio -- Compiled task producing a segmentation violation + spperr -- Compiled task invoking the SPP error() function + + + +Reporting of Errors +=================== + +Traceback +--------- + + The most obvious change to users will be in the traceback of errors +reported by the ECL. As an example, suppose we have a test script +called NESTED that calls several layers of other scripts until it gets +to a compiled task called FPE which simply triggers a divide-by-zero +arithmetic exception. The calling sequence we use is + + NESTED (type) # toplevel test task + NEST0 (type) # hidden script task + ERRTYPE (type) # script task + FPE () # compiled task giving the error + +(The 'type' argument here is a code used to test various types of system +errors but its value isn't important to the current discussion.) In the +traditional CL, executing this script results in the following and familiar +message: + cl> nested 1 + ERROR on line 72: floating point divide by zero + errtype (type=1) + nested (type=1) + +There are a number of issues with the error report here we wish to correct: + + 1) The error is reported to be on line 72, but none of the scripts + called invoke any task on that line, or even have that many lines, + and so it is clearly wrong. + 2) Was it the ERRTYPE script that caused an error or something else? + 3) There is no mention of the FPE task we know to be the culprit. + +These problems are resolved in the ECL where the error report now looks like: + + cl> nested 1 + ERROR: floating point divide by zero + "fpe ()" + line 15: errtest$errtype.cl + called as: `errtype (type=1)' + "errtype (type)" + line 13: errtest$nest0.cl (hidden task) + called as: `nest0 (type=1)' + "nest0 (type)" + line 11: errtest$nested.cl + called as: `nested (type=1)' + +The traceback is more complete and begins with the task which actually +throws the error. Checking the line numbers of the ERRTEST package +scripts we find that indeed FPE is called on line 15 of 'errtype.cl', +ERRTYPE is called from line 13 of 'nest0.cl', and so on. + + For each task in the calling sequence the format of the traceback is + +